aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 19:43:48 -0500
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-11-06 19:43:48 -0500
commit24b68e6d7408f50023272e765687eab777596363 (patch)
tree36109508292ec57f01529ab31699ed8837d3f0c8
parentdd4d718ac9f0a9862ebef19beb568bbedcc85848 (diff)
Tree demo working (and other assorted regressions fixed)
Diffstat
-rw-r--r--demo/crud.ur8
-rw-r--r--demo/prose4
-rw-r--r--demo/refFun.ur8
-rw-r--r--demo/sql.ur4
-rw-r--r--demo/tree.ur22
-rw-r--r--demo/tree.urp2
-rw-r--r--demo/treeFun.ur2
-rw-r--r--lib/top.ur4
-rw-r--r--src/cjr_print.sml37
-rw-r--r--src/elab_env.sig1
-rw-r--r--src/elab_env.sml3
-rw-r--r--src/elaborate.sml16
-rw-r--r--src/monoize.sml16
-rw-r--r--src/urweb.grm6
14 files changed, 109 insertions, 24 deletions
diff --git a/demo/crud.ur b/demo/crud.ur
index ee6a95f6..a120cb2a 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -102,7 +102,7 @@ functor Make(M : sig
[[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 @@ functor Make(M : sig
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 @@ functor Make(M : sig
</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 @@ functor Make(M : sig
</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>
diff --git a/demo/prose b/demo/prose
index fad98e26..11661211 100644
--- a/demo/prose
+++ b/demo/prose
@@ -132,6 +132,10 @@ metaform2.urp
<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>
diff --git a/demo/refFun.ur b/demo/refFun.ur
index d648f31e..e523bac7 100644
--- a/demo/refFun.ur
+++ b/demo/refFun.ur
@@ -10,19 +10,19 @@ functor Make(M : sig
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
diff --git a/demo/sql.ur b/demo/sql.ur
index 43a69573..44ff478f 100644
--- a/demo/sql.ur
+++ b/demo/sql.ur
@@ -27,7 +27,7 @@ fun list () =
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 add r =
and delete a =
dml (DELETE FROM t
- WHERE t.A = {a});
+ WHERE t.A = {[a]});
xml <- list ();
return <xml><body>
<p>Row deleted.</p>
diff --git a/demo/tree.ur b/demo/tree.ur
index 06a30cf9..27e9aa21 100644
--- a/demo/tree.ur
+++ b/demo/tree.ur
@@ -1,3 +1,4 @@
+sequence s
table t : { Id : int, Parent : option int, Nam : string }
open TreeFun.Make(struct
@@ -5,11 +6,28 @@ open TreeFun.Make(struct
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 ()
diff --git a/demo/tree.urp b/demo/tree.urp
index 2270dd06..880a7ab4 100644
--- a/demo/tree.urp
+++ b/demo/tree.urp
@@ -1,5 +1,5 @@
debug
-database dbname=tree
+database dbname=test
sql tree.sql
treeFun
diff --git a/demo/treeFun.ur b/demo/treeFun.ur
index 236f354c..15fe60f5 100644
--- a/demo/treeFun.ur
+++ b/demo/treeFun.ur
@@ -18,7 +18,7 @@ functor Make(M : sig
(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>
diff --git a/lib/top.ur b/lib/top.ur
index 5d00282c..76fe73c1 100644
--- a/lib/top.ur
+++ b/lib/top.ur
@@ -230,12 +230,12 @@ fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
(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 --git a/src/cjr_print.sml b/src/cjr_print.sml
index 2485e317..3941fdd9 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -799,6 +799,43 @@ fun unurlify env (t, loc) =
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 --git a/src/elab_env.sig b/src/elab_env.sig
index 90cf8153..926837e1 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -74,6 +74,7 @@ signature ELAB_ENV = sig
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 --git a/src/elab_env.sml b/src/elab_env.sml
index 46f62727..05da56db 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -542,6 +542,9 @@ fun lookupENamed (env : env) n =
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 --git a/src/elaborate.sml b/src/elaborate.sml
index f0beecdd..e84f5307 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2282,9 +2282,15 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
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 subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
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 --git a/src/monoize.sml b/src/monoize.sml
index 9e1a4d22..ee509f52 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -390,6 +390,22 @@ fun fooifyExp fk env =
((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 --git a/src/urweb.grm b/src/urweb.grm
index 4ac14450..b49cd793 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1236,7 +1236,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In
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 : TRUE (sql_inject (EVar (["Basis"], "True", In
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),
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 11:50:38 +0000