Mercurial > urweb
changeset 1682:ac141fbb313a
'ORDER BY RANDOM' (based on a patch from Ron de Bruijn)
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Thu, 02 Feb 2012 11:40:10 -0500 |
| parents | e8a84494d2c0 |
| children | be1ed46d73e2 |
| files | lib/ur/basis.urs src/elisp/urweb-mode.el src/monoize.sml src/mysql.sml src/postgres.sml src/settings.sig src/settings.sml src/sqlite.sml src/urweb.grm src/urweb.lex tests/random.ur tests/random.urp |
| diffstat | 12 files changed, 69 insertions(+), 41 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Sun Jan 22 20:25:14 2012 -0500 +++ b/lib/ur/basis.urs Thu Feb 02 11:40:10 2012 -0500 @@ -399,7 +399,7 @@ selectedExps) } -> sql_query1 free afree tables selectedFields selectedExps -type sql_relop +type sql_relop val sql_union : sql_relop val sql_intersect : sql_relop val sql_except : sql_relop @@ -428,11 +428,13 @@ -> sql_exp tables [] exps t -> sql_direction -> sql_order_by tables exps -> sql_order_by tables exps +val sql_order_by_random : tables ::: {{Type}} -> exps ::: {Type} + -> sql_order_by tables exps type sql_limit val sql_no_limit : sql_limit val sql_limit : int -> sql_limit - + type sql_offset val sql_no_offset : sql_offset val sql_offset : int -> sql_offset @@ -651,7 +653,7 @@ ctxOuter ctxInner useOuter bindOuter -> xml ctxInner useInner bindInner -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) -val join : ctx ::: {Unit} +val join : ctx ::: {Unit} -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} -> [use1 ~ bind1] => [bind1 ~ bind2] => xml ctx use1 bind1 @@ -769,13 +771,13 @@ val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int, Onabort = transaction unit, Onerror = transaction unit, Onload = transaction unit] ++ boxAttrs) - + val form : ctx ::: {Unit} -> bind ::: {Type} -> [[MakeForm, Form] ~ ctx] => option css_class -> xml ([Form] ++ ctx) [] bind -> xml ([MakeForm] ++ ctx) [] [] - + val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> [[Form] ~ ctx] => nm :: Name -> [[nm] ~ use] =>
--- a/src/elisp/urweb-mode.el Sun Jan 22 20:25:14 2012 -0500 +++ b/src/elisp/urweb-mode.el Thu Feb 02 11:40:10 2012 -0500 @@ -151,7 +151,7 @@ "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK" "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL" "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1" - "IF" "THEN" "ELSE" "COALESCE" "LIKE") + "IF" "THEN" "ELSE" "COALESCE" "LIKE" "RANDOM") "A regexp that matches SQL keywords.") (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
--- a/src/monoize.sml Sun Jan 22 20:25:14 2012 -0500 +++ b/src/monoize.sml Thu Feb 02 11:40:10 2012 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -74,7 +74,7 @@ SM.insert (fs', x, n))) ([], SM.empty) (r, fs) in pvars := RM.insert (!pvars, r', (n, fs)); - pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc) + pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc) :: !pvarDefs; pvarOldDefs := (n, r) :: !pvarOldDefs; (n, fs) @@ -312,9 +312,9 @@ let val r = ref (L'.Default, []) val (_, xs, xncs) = Env.lookupDatatype env n - + val dtmap' = IM.insert (dtmap, n, r) - + val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs in case xs of @@ -580,7 +580,7 @@ result = ran}), loc)), loc), "")], loc), fm) - end + end val (fm, n) = Fm.lookup fm fk i makeDecl in @@ -594,7 +594,7 @@ ((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))], @@ -1186,7 +1186,7 @@ ((L'.EAbs ("f", dom, dom, (L'.ERel 0, loc)), loc), fm) end - + | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => let val t = monoType env t @@ -2059,7 +2059,7 @@ strcat [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 @@ -2194,7 +2194,7 @@ | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"), _), _), _), _), _), _), _), _) => let - val un = (L'.TRecord [], loc) + val un = (L'.TRecord [], loc) in ((L'.EAbs ("_", un, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, @@ -2406,6 +2406,8 @@ | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => ((L'.EPrim (Prim.String ""), loc), fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => + ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2755,7 +2757,6 @@ | 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 ( @@ -2763,7 +2764,7 @@ (L.EFfi ("Basis", "sql_nfunc"), _), _), _), _), _), - _), _), + _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -2893,7 +2894,7 @@ (L'.ERel 0, loc)), loc)), loc), fm) end - + | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3045,7 +3046,7 @@ | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc) | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc) | x :: rest => findOnload (rest, onload, onunload, x :: acc) - + val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, []) val (class, fm) = monoExp (env, st, fm) class @@ -3325,7 +3326,7 @@ List.exists (fn ((L.CName tag', _), _) => tag' = tag | _ => false) ctx | _ => false - + val tag = if inTag "Tr" then "tr" else if inTag "Table" then @@ -3343,7 +3344,7 @@ fm) | _ => raise Fail "Monoize: Bad dyn attributes" end - + | "submit" => normal ("input type=\"submit\"", NONE, NONE) | "image" => normal ("input type=\"image\"", NONE, NONE) | "button" => normal ("input type=\"submit\"", NONE, NONE) @@ -4312,7 +4313,7 @@ let val (nExp, fm) = Fm.freshName fm val (nIni, fm) = Fm.freshName fm - + val dExp = L'.DVal ("expunger", nExp, (L'.TFun (client, unit), loc),
--- a/src/mysql.sml Sun Jan 22 20:25:14 2012 -0500 +++ b/src/mysql.sml Thu Feb 02 11:40:10 2012 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -258,7 +258,7 @@ string "mysql_free_result(res);", newline, newline, - + string "if (mysql_query(conn->conn, \"", string q'', string "\")) {", @@ -503,7 +503,7 @@ string "static void uw_db_validate(uw_context ctx) { }"], newline, newline, - + string "static void uw_db_init(uw_context ctx) {", newline, string "MYSQL *mysql = mysql_init(NULL);", @@ -829,7 +829,7 @@ string (Int.toString i), string ";", newline, - + case t of Nullable t => buffers t | _ => buffers t, @@ -1123,7 +1123,7 @@ string (Int.toString i), string ";", newline] - + | _ => box [string "in[", string (Int.toString i), string "].buffer = &arg", @@ -1137,7 +1137,7 @@ string (p_buffer_type t), string ";", newline, - + case t of Nullable t => box [string "in[", string (Int.toString i), @@ -1177,7 +1177,7 @@ newline], string "}", newline] - + | _ => buffers t, newline] end) inputs, @@ -1404,7 +1404,7 @@ string (Int.toString i), string ";", newline] - + | _ => box [string "in[", string (Int.toString i), string "].buffer = &arg", @@ -1425,7 +1425,7 @@ string "].is_unsigned = 1;", newline] | _ => box [], - + case t of Nullable t => box [string "in[", string (Int.toString i), @@ -1465,7 +1465,7 @@ newline], string "}", newline] - + | _ => buffers t, newline] end) inputs, @@ -1529,6 +1529,7 @@ val () = addDbms {name = "mysql", header = Config.msheader, + randomFunction = "RAND", link = "-lmysqlclient", init = init, p_sql_type = p_sql_type,
--- a/src/postgres.sml Sun Jan 22 20:25:14 2012 -0500 +++ b/src/postgres.sml Thu Feb 02 11:40:10 2012 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -645,7 +645,7 @@ newline, newline, string "uw_pop_cleanup(ctx);", - newline] + newline] fun query {loc, cols, doCols} = box [string "PGconn *conn = uw_get_db(ctx);", @@ -1037,6 +1037,7 @@ fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t) val () = addDbms {name = "postgres", + randomFunction = "RANDOM", header = Config.pgheader, link = "-lpq", p_sql_type = p_sql_type,
--- a/src/settings.sig Sun Jan 22 20:25:14 2012 -0500 +++ b/src/settings.sig Thu Feb 02 11:40:10 2012 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -26,10 +26,10 @@ *) signature SETTINGS = sig - + val setDebug : bool -> unit val getDebug : unit -> bool - + val clibFile : string -> string (* How do all application URLs begin? *) @@ -143,6 +143,8 @@ type dbms = { name : string, (* Call it this on the command line *) + randomFunction : string, + (* DBMS's name for random number-generating function *) header : string, (* Include this C header file *) link : string,
--- a/src/settings.sml Sun Jan 22 20:25:14 2012 -0500 +++ b/src/settings.sml Thu Feb 02 11:40:10 2012 -0500 @@ -467,6 +467,7 @@ type dbms = { name : string, + randomFunction : string, header : string, link : string, p_sql_type : sql_type -> string, @@ -511,6 +512,7 @@ val dbmses = ref ([] : dbms list) val curDb = ref ({name = "", + randomFunction = "", header = "", link = "", p_sql_type = fn _ => "",
--- a/src/sqlite.sml Sun Jan 22 20:25:14 2012 -0500 +++ b/src/sqlite.sml Thu Feb 02 11:40:10 2012 -0500 @@ -16,7 +16,7 @@ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN @@ -255,7 +255,7 @@ string "static void uw_db_validate(uw_context ctx) { }"], newline, newline, - + string "static void uw_db_init(uw_context ctx) {", newline, string "sqlite3 *sqlite;", @@ -308,7 +308,7 @@ string "}", newline, newline, - + string "conn = calloc(1, sizeof(uw_conn));", newline, string "conn->conn = sqlite;", @@ -820,6 +820,7 @@ fun p_blank _ = "?" val () = addDbms {name = "sqlite", + randomFunction = "RANDOM", header = Config.sqheader, link = "-lsqlite3", init = init,
--- a/src/urweb.grm Sun Jan 22 20:25:14 2012 -0500 +++ b/src/urweb.grm Thu Feb 02 11:40:10 2012 -0500 @@ -276,7 +276,7 @@ | LIMIT | OFFSET | ALL | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX - | ASC | DESC + | ASC | DESC | RANDOM | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -405,6 +405,7 @@ | obopt of exp | obitem of exp * exp | obexps of exp + | popt of unit | diropt of exp | lopt of exp | ofopt of exp @@ -2034,6 +2035,10 @@ in (EApp (e, obexps), loc) end) + | RANDOM popt (EVar (["Basis"], "sql_order_by_random", Infer), s (RANDOMleft, poptright)) + +popt : () + | LPAREN RPAREN () diropt : (EVar (["Basis"], "sql_asc", Infer), dummy) | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
--- a/src/urweb.lex Sun Jan 22 20:25:14 2012 -0500 +++ b/src/urweb.lex Thu Feb 02 11:40:10 2012 -0500 @@ -490,6 +490,7 @@ <INITIAL> "ASC" => (Tokens.ASC (pos yypos, pos yypos + size yytext)); <INITIAL> "DESC" => (Tokens.DESC (pos yypos, pos yypos + size yytext)); +<INITIAL> "RANDOM" => (Tokens.RANDOM (pos yypos, pos yypos + size yytext)); <INITIAL> "INSERT" => (Tokens.INSERT (pos yypos, pos yypos + size yytext)); <INITIAL> "INTO" => (Tokens.INTO (pos yypos, pos yypos + size yytext));
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/random.ur Thu Feb 02 11:40:10 2012 -0500 @@ -0,0 +1,8 @@ +table t : { A : int } + +fun main () : transaction page = + x <- queryX (SELECT * + FROM t + ORDER BY RANDOM) + (fn r => <xml>{[r.T.A]}<br/></xml>); + return <xml><body>{x}</body></xml>