diff options
author | Adam Chlipala <adam@chlipala.net> | 2012-02-02 11:40:10 -0500 |
---|---|---|
committer | Adam Chlipala <adam@chlipala.net> | 2012-02-02 11:40:10 -0500 |
commit | 1a92bdc65a47614912b4bfd0cf6f442d7134ce23 (patch) | |
tree | 5271983ec2581bb6cf7fecc8053b8c3e41de9250 | |
parent | 912c6fcf0c09348965262dd13c8faaefa61c2999 (diff) |
'ORDER BY RANDOM' (based on a patch from Ron de Bruijn)
-rw-r--r-- | lib/ur/basis.urs | 12 | ||||
-rw-r--r-- | src/elisp/urweb-mode.el | 2 | ||||
-rw-r--r-- | src/monoize.sml | 33 | ||||
-rw-r--r-- | src/mysql.sml | 21 | ||||
-rw-r--r-- | src/postgres.sml | 5 | ||||
-rw-r--r-- | src/settings.sig | 8 | ||||
-rw-r--r-- | src/settings.sml | 2 | ||||
-rw-r--r-- | src/sqlite.sml | 7 | ||||
-rw-r--r-- | src/urweb.grm | 7 | ||||
-rw-r--r-- | src/urweb.lex | 1 | ||||
-rw-r--r-- | tests/random.ur | 8 | ||||
-rw-r--r-- | tests/random.urp | 4 |
12 files changed, 69 insertions, 41 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 08585546..3afb4985 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -399,7 +399,7 @@ val sql_query1 : free ::: {{Type}} 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 @@ val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> 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 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} 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 a : bodyTag ([Link = transaction page, Href = url, Target = string] ++ boxAt 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] => diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index b5c42cbe..480ba1f6 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -151,7 +151,7 @@ See doc for the variable `urweb-mode-info'." "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_']*\\>" diff --git a/src/monoize.sml b/src/monoize.sml index ccadf936..1331d065 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -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 @@ fun pvar (r, r', loc) = 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 @@ fun monoType env = 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 @@ fun fooifyExp fk env = result = ran}), loc)), loc), "")], loc), fm) - end + end val (fm, n) = Fm.lookup fm fk i makeDecl in @@ -594,7 +594,7 @@ fun fooifyExp fk env = ((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | 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 @@ 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 ( @@ -2763,7 +2764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_nfunc"), _), _), _), _), _), - _), _), + _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) @@ -2893,7 +2894,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ERel 0, loc)), loc)), loc), fm) end - + | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3045,7 +3046,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | ("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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoize env file = let val (nExp, fm) = Fm.freshName fm val (nIni, fm) = Fm.freshName fm - + val dExp = L'.DVal ("expunger", nExp, (L'.TFun (client, unit), loc), diff --git a/src/mysql.sml b/src/mysql.sml index 686f430f..780f5148 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -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 @@ fun checkRel (table, checkNullable) (s, xts) = string "mysql_free_result(res);", newline, newline, - + string "if (mysql_query(conn->conn, \"", string q'', string "\")) {", @@ -503,7 +503,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = 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 @@ fun queryCommon {loc, query, cols, doCols} = string (Int.toString i), string ";", newline, - + case t of Nullable t => buffers t | _ => buffers t, @@ -1123,7 +1123,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = string (Int.toString i), string ";", newline] - + | _ => box [string "in[", string (Int.toString i), string "].buffer = &arg", @@ -1137,7 +1137,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = string (p_buffer_type t), string ";", newline, - + case t of Nullable t => box [string "in[", string (Int.toString i), @@ -1177,7 +1177,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = newline], string "}", newline] - + | _ => buffers t, newline] end) inputs, @@ -1404,7 +1404,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} = string (Int.toString i), string ";", newline] - + | _ => box [string "in[", string (Int.toString i), string "].buffer = &arg", @@ -1425,7 +1425,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} = string "].is_unsigned = 1;", newline] | _ => box [], - + case t of Nullable t => box [string "in[", string (Int.toString i), @@ -1465,7 +1465,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} = newline], string "}", newline] - + | _ => buffers t, newline] end) inputs, @@ -1529,6 +1529,7 @@ fun p_blank _ = "?" val () = addDbms {name = "mysql", header = Config.msheader, + randomFunction = "RAND", link = "-lmysqlclient", init = init, p_sql_type = p_sql_type, diff --git a/src/postgres.sml b/src/postgres.sml index 3a2fd40d..db9c9d3a 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -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 @@ fun queryCommon {loc, query, cols, doCols} = 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_cast (s, t) = s ^ "::" ^ p_sql_type t 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, diff --git a/src/settings.sig b/src/settings.sig index 26e220fd..62b7a748 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -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 @@ signature SETTINGS = sig 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, diff --git a/src/settings.sml b/src/settings.sml index b421f38a..017c5095 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -467,6 +467,7 @@ datatype failure_mode = Error | None type dbms = { name : string, + randomFunction : string, header : string, link : string, p_sql_type : sql_type -> string, @@ -511,6 +512,7 @@ type dbms = { val dbmses = ref ([] : dbms list) val curDb = ref ({name = "", + randomFunction = "", header = "", link = "", p_sql_type = fn _ => "", diff --git a/src/sqlite.sml b/src/sqlite.sml index 1dc0b754..f7d8f824 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -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 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = 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 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = string "}", newline, newline, - + string "conn = calloc(1, sizeof(uw_conn));", newline, string "conn->conn = sqlite;", @@ -820,6 +820,7 @@ fun p_cast (s, _) = s fun p_blank _ = "?" val () = addDbms {name = "sqlite", + randomFunction = "RANDOM", header = Config.sqheader, link = "-lsqlite3", init = init, diff --git a/src/urweb.grm b/src/urweb.grm index a495bfe6..7d2bc96b 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -276,7 +276,7 @@ fun tnamesOf (e, _) = | 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 @@ fun tnamesOf (e, _) = | 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 @@ obexps : obitem (let 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)) diff --git a/src/urweb.lex b/src/urweb.lex index b3b590f2..50ebe843 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -490,6 +490,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <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)); diff --git a/tests/random.ur b/tests/random.ur new file mode 100644 index 00000000..b2006302 --- /dev/null +++ b/tests/random.ur @@ -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> diff --git a/tests/random.urp b/tests/random.urp new file mode 100644 index 00000000..5cc06fe5 --- /dev/null +++ b/tests/random.urp @@ -0,0 +1,4 @@ +database dbname=test +sql random.sql + +random |