Mercurial > urweb
changeset 441:c5335613f31e
CURRENT_TIMESTAMP
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 30 Oct 2008 15:33:28 -0400 |
| parents | 19d7f79cd584 |
| children | 9095a95a1bf9 |
| files | lib/basis.urs src/monoize.sml src/urweb.grm src/urweb.lex tests/time.ur |
| diffstat | 5 files changed, 101 insertions(+), 58 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/basis.urs Thu Oct 30 15:16:37 2008 -0400 +++ b/lib/basis.urs Thu Oct 30 15:33:28 2008 -0400 @@ -223,6 +223,12 @@ 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 *)
--- a/src/monoize.sml Thu Oct 30 15:16:37 2008 -0400 +++ b/src/monoize.sml Thu Oct 30 15:33:28 2008 -0400 @@ -171,6 +171,8 @@ (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 @@ 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) - ], + @ 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) + (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 @@ | 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)
--- a/src/urweb.grm Thu Oct 30 15:16:37 2008 -0400 +++ b/src/urweb.grm Thu Oct 30 15:33:28 2008 -0400 @@ -154,6 +154,13 @@ (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 @@ | 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 @@ 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)
--- a/src/urweb.lex Thu Oct 30 15:16:37 2008 -0400 +++ b/src/urweb.lex Thu Oct 30 15:33:28 2008 -0400 @@ -356,6 +356,8 @@ <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));
--- a/tests/time.ur Thu Oct 30 15:16:37 2008 -0400 +++ b/tests/time.ur Thu Oct 30 15:33:28 2008 -0400 @@ -7,9 +7,9 @@ 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>