summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.urs6
-rw-r--r--src/monoize.sml139
-rw-r--r--src/urweb.grm10
-rw-r--r--src/urweb.lex2
-rw-r--r--tests/time.ur4
5 files changed, 102 insertions, 59 deletions
diff --git a/lib/basis.urs b/lib/basis.urs
index ffb13330..8992bc8c 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -223,6 +223,12 @@ val sql_maxable_time : sql_maxable time
val sql_max : t ::: Type -> sql_maxable t -> sql_aggregate t
val sql_min : t ::: Type -> sql_maxable t -> sql_aggregate t
+con sql_nfunc :: Type -> Type
+val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+ -> t ::: Type
+ -> sql_nfunc t -> sql_exp tables agg exps t
+val sql_current_timestamp : sql_nfunc time
+
(*** Executing queries *)
diff --git a/src/monoize.sml b/src/monoize.sml
index d28b27e4..df775554 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -171,6 +171,8 @@ fun monoType env =
(L'.TRecord [], loc)
| L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
(L'.TRecord [], loc)
+ | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
| L.CRel _ => poly ()
| L.CNamed n =>
@@ -1126,64 +1128,69 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of
(SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) =>
- ((L'.EAbs ("r",
- (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
- ("Where", s),
- ("GroupBy", un),
- ("Having", s),
- ("SelectFields", un),
- ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
- loc),
- s,
- strcat loc [sc "SELECT ",
- strcatComma loc (map (fn (x, t) =>
- strcat loc [
- (L'.EField (gf "SelectExps", x), loc),
- sc (" AS _" ^ x)
+ let
+ val sexps = ListMergeSort.sort
+ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
+ in
+ ((L'.EAbs ("r",
+ (L'.TRecord [("From", (L'.TRecord (map (fn (x, _) => (x, s)) tables), loc)),
+ ("Where", s),
+ ("GroupBy", un),
+ ("Having", s),
+ ("SelectFields", un),
+ ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
+ loc),
+ s,
+ strcat loc [sc "SELECT ",
+ strcatComma loc (map (fn (x, t) =>
+ strcat loc [
+ (L'.EField (gf "SelectExps", x), loc),
+ sc (" AS _" ^ x)
]) sexps
- @ map (fn (x, xts) =>
- strcatComma loc
- (map (fn (x', _) =>
- sc (x ^ ".uw_" ^ x'))
- xts)) stables),
- sc " FROM ",
- strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc),
- sc (" AS " ^ x)]) tables),
- (L'.ECase (gf "Where",
- [((L'.PPrim (Prim.String "TRUE"), loc),
- sc ""),
- ((L'.PWild, loc),
- strcat loc [sc " WHERE ", gf "Where"])],
- {disc = s,
- result = s}), loc),
-
- if List.all (fn (x, xts) =>
- case List.find (fn (x', _) => x' = x) grouped of
- NONE => List.null xts
- | SOME (_, xts') =>
- List.all (fn (x, _) =>
- List.exists (fn (x', _) => x' = x)
- xts') xts) tables then
- sc ""
- else
- strcat loc [
- sc " GROUP BY ",
- strcatComma loc (map (fn (x, xts) =>
- strcatComma loc
- (map (fn (x', _) =>
- sc (x ^ ".uw_" ^ x'))
- xts)) grouped)
- ],
-
- (L'.ECase (gf "Having",
- [((L'.PPrim (Prim.String "TRUE"), loc),
- sc ""),
- ((L'.PWild, loc),
- strcat loc [sc " HAVING ", gf "Having"])],
- {disc = s,
- result = s}), loc)
- ]), loc),
- fm)
+ @ map (fn (x, xts) =>
+ strcatComma loc
+ (map (fn (x', _) =>
+ sc (x ^ ".uw_" ^ x'))
+ xts)) stables),
+ sc " FROM ",
+ strcatComma loc (map (fn (x, _) => strcat loc [(L'.EField (gf "From", x), loc),
+ sc (" AS " ^ x)]) tables),
+ (L'.ECase (gf "Where",
+ [((L'.PPrim (Prim.String "TRUE"), loc),
+ sc ""),
+ ((L'.PWild, loc),
+ strcat loc [sc " WHERE ", gf "Where"])],
+ {disc = s,
+ result = s}), loc),
+
+ if List.all (fn (x, xts) =>
+ case List.find (fn (x', _) => x' = x) grouped of
+ NONE => List.null xts
+ | SOME (_, xts') =>
+ List.all (fn (x, _) =>
+ List.exists (fn (x', _) => x' = x)
+ xts') xts) tables then
+ sc ""
+ else
+ strcat loc [
+ sc " GROUP BY ",
+ strcatComma loc (map (fn (x, xts) =>
+ strcatComma loc
+ (map (fn (x', _) =>
+ sc (x ^ ".uw_" ^ x'))
+ xts)) grouped)
+ ],
+
+ (L'.ECase (gf "Having",
+ [((L'.PPrim (Prim.String "TRUE"), loc),
+ sc ""),
+ ((L'.PWild, loc),
+ strcat loc [sc " HAVING ", gf "Having"])],
+ {disc = s,
+ result = s}), loc)
+ ]), loc),
+ fm)
+ end
| _ => poly ()
end
@@ -1498,6 +1505,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
| L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_nfunc"), _),
+ _), _),
+ _), _),
+ _), _),
+ _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ fun sc s = (L'.EPrim (Prim.String s), loc)
+ in
+ ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
+ fm)
+ end
+ | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
+
| L.EFfiApp ("Basis", "nextval", [e]) =>
let
val un = (L'.TRecord [], loc)
diff --git a/src/urweb.grm b/src/urweb.grm
index 4f470fa0..3f56cb94 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -154,6 +154,13 @@ fun sql_relop (oper, sqlexp1, sqlexp2, loc) =
(EApp (e, sqlexp2), loc)
end
+fun sql_nfunc (oper, loc) =
+ let
+ val e = (EVar (["Basis"], "sql_nfunc", Infer), loc)
+ in
+ (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc)
+ end
+
fun native_unop (oper, e1, loc) =
let
val e = (EVar (["Basis"], oper, Infer), loc)
@@ -206,6 +213,7 @@ fun tagIn bt =
| COUNT | AVG | SUM | MIN | MAX
| ASC | DESC
| INSERT | INTO | VALUES | UPDATE | SET | DELETE
+ | CURRENT_TIMESTAMP
| NE | LT | LE | GT | GE
%nonterm
@@ -1169,6 +1177,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In
s (FLOATleft, FLOATright)))
| STRING (sql_inject (EPrim (Prim.String STRING),
s (STRINGleft, STRINGright)))
+ | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
+ s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))
| tident DOT fident (let
val loc = s (tidentleft, fidentright)
diff --git a/src/urweb.lex b/src/urweb.lex
index fd8a8077..fc8db17f 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -356,6 +356,8 @@ notags = [^<{\n]+;
<INITIAL> "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext));
<INITIAL> "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
+<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
+
<INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
diff --git a/tests/time.ur b/tests/time.ur
index f81c59c3..8676c48f 100644
--- a/tests/time.ur
+++ b/tests/time.ur
@@ -7,9 +7,9 @@ fun main () =
dml (INSERT INTO t (Id, Time) VALUES (42, {now}));
xml <- queryX (SELECT * FROM t)
(fn r => <xml>{[r.T.Id]}: {[r.T.Time]}<br/></xml>);
- minMax <- oneRow (SELECT MIN(t.Time) AS Min, MAX(t.Time) AS Max FROM t);
+ minMax <- oneRow (SELECT CURRENT_TIMESTAMP AS Cur, MIN(t.Time) AS Min, MAX(t.Time) AS Max FROM t);
return <xml><body>
{xml}
{[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]}<br/>
- {[minMax.Min]}, {[minMax.Max]}
+ {[minMax.Cur]}, {[minMax.Min]}, {[minMax.Max]}
</body></xml>
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-20 19:33:48 +0000