summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-10-27 08:27:45 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-10-27 08:27:45 -0400
commit5d118aafe9b7cecdb429836b61bb9fdf6e8fc24e (patch)
tree4f228e945fd003d5a15b6d45fb34f50b6a41722c
parent794a3ad4e4713e74d2118d8f24b09ef4d35bd34f (diff)
Remove need for '() <-' notation
-rw-r--r--CHANGELOG1
-rw-r--r--demo/crud.ur44
-rw-r--r--demo/ref.ur8
-rw-r--r--demo/refFun.ur2
-rw-r--r--demo/sql.ur8
-rw-r--r--src/urweb.grm30
6 files changed, 50 insertions, 43 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 6b62d606..1c20780e 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -3,6 +3,7 @@
========
- On missing inputs, print an error message, but don't exit the web server.
+- Remove need for "() <-" notation.
========
20081026
diff --git a/demo/crud.ur b/demo/crud.ur
index 472de6d4..77fccf16 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -94,15 +94,15 @@ functor Make(M : sig
and create (inputs : $(mapT2T sndTT M.cols)) =
id <- nextval seq;
- () <- dml (insert tab
- (foldT2R2 [sndTT] [colMeta]
- [fn cols => $(mapT2T (fn t :: (Type * Type) =>
- sql_exp [] [] [] t.1) cols)]
- (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
- [[nm] ~ rest] =>
- fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input))
- {} [M.cols] inputs M.cols
- with #Id = (SQL {id})));
+ dml (insert tab
+ (foldT2R2 [sndTT] [colMeta]
+ [fn cols => $(mapT2T (fn t :: (Type * Type) =>
+ sql_exp [] [] [] t.1) cols)]
+ (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+ [[nm] ~ rest] =>
+ fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input))
+ {} [M.cols] inputs M.cols
+ with #Id = (SQL {id})));
ls <- list ();
return <xml><body>
<p>Inserted with ID {[id]}.</p>
@@ -111,18 +111,18 @@ functor Make(M : sig
</body></xml>
and save (id : int) (inputs : $(mapT2T sndTT M.cols)) =
- () <- dml (update [mapT2T fstTT M.cols]
- (foldT2R2 [sndTT] [colMeta]
- [fn cols => $(mapT2T (fn t :: (Type * Type) =>
- sql_exp [T = [Id = int]
- ++ mapT2T fstTT M.cols]
- [] [] t.1) cols)]
- (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
- [[nm] ~ rest] =>
- fn input col acc => acc with nm =
- @sql_inject col.Inject (col.Parse input))
- {} [M.cols] inputs M.cols)
- tab (WHERE T.Id = {id}));
+ dml (update [mapT2T fstTT M.cols]
+ (foldT2R2 [sndTT] [colMeta]
+ [fn cols => $(mapT2T (fn t :: (Type * Type) =>
+ sql_exp [T = [Id = int]
+ ++ mapT2T fstTT M.cols]
+ [] [] t.1) cols)]
+ (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+ [[nm] ~ rest] =>
+ fn input col acc => acc with nm =
+ @sql_inject col.Inject (col.Parse input))
+ {} [M.cols] inputs M.cols)
+ tab (WHERE T.Id = {id}));
ls <- list ();
return <xml><body>
<p>Saved!</p>
@@ -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/ref.ur b/demo/ref.ur
index 089529e3..4030b6fa 100644
--- a/demo/ref.ur
+++ b/demo/ref.ur
@@ -13,15 +13,15 @@ fun main () =
ir' <- IR.new 7;
sr <- SR.new "hi";
- () <- IR.write ir' 10;
+ IR.write ir' 10;
iv <- IR.read ir;
iv' <- IR.read ir';
sv <- SR.read sr;
- () <- IR.delete ir;
- () <- IR.delete ir';
- () <- SR.delete sr;
+ IR.delete ir;
+ IR.delete ir';
+ SR.delete sr;
return <xml><body>
{[iv]}, {[iv']}, {[sv]}
diff --git a/demo/refFun.ur b/demo/refFun.ur
index a090b297..d648f31e 100644
--- a/demo/refFun.ur
+++ b/demo/refFun.ur
@@ -10,7 +10,7 @@ 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 =
diff --git a/demo/sql.ur b/demo/sql.ur
index 9e9effff..43a69573 100644
--- a/demo/sql.ur
+++ b/demo/sql.ur
@@ -26,8 +26,8 @@ fun list () =
</xml>
and add r =
- () <- dml (INSERT INTO t (A, B, C, D)
- VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D}));
+ dml (INSERT INTO t (A, B, C, D)
+ VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D}));
xml <- list ();
return <xml><body>
<p>Row added.</p>
@@ -36,8 +36,8 @@ and add r =
</body></xml>
and delete a =
- () <- dml (DELETE FROM t
- WHERE t.A = {a});
+ dml (DELETE FROM t
+ WHERE t.A = {a});
xml <- list ();
return <xml><body>
<p>Row deleted.</p>
diff --git a/src/urweb.grm b/src/urweb.grm
index 9a9081a3..4f470fa0 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -263,6 +263,7 @@ fun tagIn bt =
| xmlOne of exp
| tag of string * exp
| tagHead of string * exp
+ | bind of string * con option * exp
| earg of exp * con -> exp * con
| eargp of exp * con -> exp * con
@@ -668,20 +669,13 @@ eexp : eapps (eapps)
(ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2),
((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc)
end)
- | SYMBOL LARROW eexp SEMI eexp (let
- val loc = s (SYMBOLleft, eexp2right)
+ | bind SEMI eexp (let
+ val loc = s (bindleft, eexpright)
+ val (v, to, e1) = bind
val e = (EVar (["Basis"], "bind", Infer), loc)
- val e = (EApp (e, eexp1), loc)
+ val e = (EApp (e, e1), loc)
in
- (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc)
- end)
- | UNIT LARROW eexp SEMI eexp (let
- val loc = s (UNITleft, eexp2right)
- val e = (EVar (["Basis"], "bind", Infer), loc)
- val e = (EApp (e, eexp1), loc)
- val t = (TRecord (CRecord [], loc), loc)
- in
- (EApp (e, (EAbs ("_", SOME t, eexp2), loc)), loc)
+ (EApp (e, (EAbs (v, to, eexp), loc)), loc)
end)
| eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
| eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
@@ -699,6 +693,18 @@ eexp : eapps (eapps)
| eexp WITH cterm EQ eexp (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right))
+bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps)
+ | UNIT LARROW eapps (let
+ val loc = s (UNITleft, eappsright)
+ in
+ ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
+ end)
+ | eapps (let
+ val loc = s (eappsleft, eappsright)
+ in
+ ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
+ end)
+
eargs : earg (earg)
| eargl (eargl)