diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-10-30 15:33:28 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-10-30 15:33:28 -0400 |
commit | a2008ff2da76acfd69886499c6f8386041a1a4e0 (patch) | |
tree | b3af420e0116388b43fc38752a344cbd9ed04b32 | |
parent | 7e90e2dd45c936519b6397a3ac9f8cb481ea6511 (diff) |
CURRENT_TIMESTAMP
-rw-r--r-- | lib/basis.urs | 6 | ||||
-rw-r--r-- | src/monoize.sml | 139 | ||||
-rw-r--r-- | src/urweb.grm | 10 | ||||
-rw-r--r-- | src/urweb.lex | 2 | ||||
-rw-r--r-- | tests/time.ur | 4 |
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> |