summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/elisp/urweb-mode.el2
-rw-r--r--src/monoize.sml33
-rw-r--r--src/mysql.sml21
-rw-r--r--src/postgres.sml5
-rw-r--r--src/settings.sig8
-rw-r--r--src/settings.sml2
-rw-r--r--src/sqlite.sml7
-rw-r--r--src/urweb.grm7
-rw-r--r--src/urweb.lex1
9 files changed, 50 insertions, 36 deletions
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));
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-06 11:00:24 +0000