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>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/random.urp	Thu Feb 02 11:40:10 2012 -0500
@@ -0,0 +1,4 @@
+database dbname=test
+sql random.sql
+
+random