summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--configure.ac2
-rw-r--r--doc/manual.tex3
-rw-r--r--lib/ur/list.ur26
-rw-r--r--lib/ur/list.urs6
-rw-r--r--src/c/memmem.c15
-rw-r--r--src/c/memmem.h23
-rw-r--r--src/c/request.c5
-rw-r--r--src/c/urweb.c2
-rw-r--r--src/cjr_print.sml8
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml10
-rw-r--r--src/core_util.sig6
-rw-r--r--src/core_util.sml16
-rw-r--r--src/demo.sml1
-rw-r--r--src/monoize.sml31
-rw-r--r--src/mysql.sml2
-rw-r--r--src/postgres.sml2
-rw-r--r--src/settings.sig5
-rw-r--r--src/settings.sml11
-rw-r--r--src/specialize.sml134
-rw-r--r--src/sqlite.sml2
-rw-r--r--tests/emptyUpdate.ur6
-rw-r--r--tests/emptyUpdate.urp4
23 files changed, 249 insertions, 73 deletions
diff --git a/configure.ac b/configure.ac
index d6b1c98f..696aac84 100644
--- a/configure.ac
+++ b/configure.ac
@@ -111,6 +111,8 @@ pthread_t a;
AC_MSG_RESULT(yes),
AC_MSG_RESULT(no))
+AC_CHECK_FUNCS_ONCE([memmem])
+
AC_SUBST(CC)
AC_SUBST(BIN)
AC_SUBST(LIB)
diff --git a/doc/manual.tex b/doc/manual.tex
index 857539db..e064e59e 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -190,6 +190,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func
\item \texttt{profile} generates an executable that may be used with gprof.
\item \texttt{rewrite KIND FROM TO} gives a rule for rewriting canonical module paths. For instance, the canonical path of a page may be \texttt{Mod1.Mod2.mypage}, while you would rather the page were accessed via a URL containing only \texttt{page}. The directive \texttt{rewrite url Mod1/Mod2/mypage page} would accomplish that. The possible values of \texttt{KIND} determine which kinds of objects are affected. The kind \texttt{all} matches any object, and \texttt{url} matches page URLs. The kinds \texttt{table}, \texttt{sequence}, and \texttt{view} match those sorts of SQL entities, and \texttt{relation} matches any of those three. \texttt{cookie} matches HTTP cookies, and \texttt{style} matches CSS class names. If \texttt{FROM} ends in \texttt{/*}, it is interpreted as a prefix matching rule, and rewriting occurs by replacing only the appropriate prefix of a path with \texttt{TO}. The \texttt{TO} field may be left empty to express the idea of deleting a prefix. For instance, \texttt{rewrite url Main/*} will strip all \texttt{Main/} prefixes from URLs. While the actual external names of relations and styles have parts separated by underscores instead of slashes, all rewrite rules must be written in terms of slashes. An optional suffix of \cd{[-]} for a \cd{rewrite} directive asks to additionally replace all \cd{\_} characters with \cd{-} characters, which can be handy for, e.g., interfacing with an off-the-shelf CSS library that prefers hyphens over underscores.
\item \texttt{safeGet URI} asks to allow the page handler assigned this canonical URI prefix to cause persistent side effects, even if accessed via an HTTP \cd{GET} request.
+\item \texttt{safeGetDefault} asks to allow \emph{any} page handler to cause side effects, even if accessed via an HTTP \cd{GET} request.
\item \texttt{script URL} adds \texttt{URL} to the list of extra JavaScript files to be included at the beginning of any page that uses JavaScript. This is most useful for importing JavaScript versions of functions found in new FFI modules.
\item \texttt{serverOnly Module.ident} registers an FFI function or transaction that may only be run on the server.
\item \texttt{sigfile PATH} sets a path where your application should look for a key to use in cryptographic signing. This is used to prevent cross-site request forgery attacks for any form handler that both reads a cookie and creates side effects. If the referenced file doesn't exist, an application will create it and read its saved data on future invocations. You can also initialize the file manually with any contents at least 16 bytes long; the first 16 bytes will be treated as the key.
@@ -2453,7 +2454,7 @@ It is most convenient to encapsulate an FFI binding with a new \texttt{.urp} fil
\item \texttt{clientOnly Module.ident} registers a value as being allowed only in client-side code.
\item \texttt{clientToServer Module.ident} declares a type as OK to marshal between clients and servers. By default, abstract FFI types are not allowed to be marshalled, since your library might be maintaining invariants that the simple serialization code doesn't check.
\item \texttt{effectful Module.ident} registers a function that can have side effects. This is the default for \texttt{transaction}-based types, and, actually, this directive is mostly present for legacy compatibility reasons, since it used to be required explicitly for each \texttt{transaction}al function.
-\item \texttt{ffi FILE.urs} names the file giving your library's signature. You can include multiple such files in a single \texttt{.urp} file, and each file \texttt{mod.urp} defines an FFI module \texttt{Mod}.
+\item \texttt{ffi FILE.urs} names the file giving your library's signature. You can include multiple such files in a single \texttt{.urp} file, and each file \texttt{mod.urs} defines an FFI module \texttt{Mod}.
\item \texttt{include FILE} requests inclusion of a C header file.
\item \texttt{jsFile FILE} requests inclusion of a JavaScript source file.
\item \texttt{jsFunc Module.ident=name} gives a mapping from an Ur name for a value to a JavaScript name.
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index d28d2868..10877420 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -153,6 +153,16 @@ fun mapM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
mapM' []
end
+fun mapMi [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
+ let
+ fun mapM' i acc ls =
+ case ls of
+ [] => return (rev acc)
+ | x :: ls => x' <- f i x; mapM' (i + 1) (x' :: acc) ls
+ in
+ mapM' 0 []
+ end
+
fun mapPartialM [m ::: (Type -> Type)] (_ : monad m) [a] [b] f =
let
fun mapPartialM' acc ls =
@@ -469,6 +479,22 @@ fun assocAdd [a] [b] (_ : eq a) (x : a) (y : b) (ls : t (a * b)) =
None => (x, y) :: ls
| Some _ => ls
+fun assocAddSorted [a] [b] (_ : eq a) (_ : ord a) (x : a) (y : b) (ls : t (a * b)) =
+ let
+ fun aas (ls : t (a * b)) (acc : t (a * b)) =
+ case ls of
+ [] => rev ((x, y) :: acc)
+ | (x', y') :: ls' =>
+ if x' = x then
+ revAppend ((x, y) :: acc) ls'
+ else if x < x' then
+ revAppend ((x, y) :: acc) ls
+ else
+ aas ls' ((x', y') :: acc)
+ in
+ aas ls []
+ end
+
fun recToList [a ::: Type] [r ::: {Unit}] (fl : folder r)
= @foldUR [a] [fn _ => list a] (fn [nm ::_] [rest ::_] [[nm] ~ rest] x xs =>
x :: xs) [] fl
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index f4593dda..c1d46022 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -31,6 +31,9 @@ val mapXi : a ::: Type -> ctx ::: {Unit} -> (int -> a -> xml ctx [] []) -> t a -
val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
-> (a -> m b) -> t a -> m (t b)
+val mapMi : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
+ -> (int -> a -> m b) -> t a -> m (t b)
+
val mapPartialM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m (option b)) -> t a -> m (t b)
val mapXM : m ::: (Type -> Type) -> monad m -> a ::: Type -> ctx ::: {Unit}
@@ -106,6 +109,9 @@ val assoc : a ::: Type -> b ::: Type -> eq a -> a -> t (a * b) -> option b
val assocAdd : a ::: Type -> b ::: Type -> eq a -> a -> b -> t (a * b) -> t (a * b)
+val assocAddSorted : a ::: Type -> b ::: Type -> eq a -> ord a -> a -> b -> t (a * b) -> t (a * b)
+(* Assume the list is already sorted in ascending order and maintain that ordering. *)
+
(** Converting records to lists *)
val recToList : a ::: Type -> r ::: {Unit} -> folder r -> $(mapU a r) -> t a
diff --git a/src/c/memmem.c b/src/c/memmem.c
index f31f4e31..efddd0c1 100644
--- a/src/c/memmem.c
+++ b/src/c/memmem.c
@@ -1,4 +1,6 @@
-#include "config.h"
+#include "memmem.h"
+
+#ifndef HAVE_MEMMEM
/* $NetBSD$ */
@@ -38,8 +40,6 @@
* POSSIBILITY OF SUCH DAMAGE.
*/
-// Function renamed by Adam Chlipala in 2016.
-
#include <sys/cdefs.h>
#if defined(LIBC_SCCS) && !defined(lint)
__RCSID("$NetBSD$");
@@ -54,13 +54,8 @@ __RCSID("$NetBSD$");
#define NULL ((char *)0)
#endif
-/*
- * urweb_memmem() returns the location of the first occurence of data
- * pattern b2 of size len2 in memory block b1 of size len1 or
- * NULL if none is found.
- */
void *
-urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2)
+memmem(const void *b1, size_t len1, const void *b2, size_t len2)
{
/* Sanity check */
if(!(b1 != NULL && b2 != NULL && len1 != 0 && len2 != 0))
@@ -85,3 +80,5 @@ urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2)
return NULL;
}
+
+#endif // !defined(HAVE_MEMMEM)
diff --git a/src/c/memmem.h b/src/c/memmem.h
new file mode 100644
index 00000000..0ddbb494
--- /dev/null
+++ b/src/c/memmem.h
@@ -0,0 +1,23 @@
+#ifndef URWEB_MEMMEM_H
+#define URWEB_MEMMEM_H
+
+#include "config.h"
+
+#ifdef HAVE_MEMMEM
+
+#include <string.h>
+
+#else // !defined(HAVE_MEMMEM)
+
+#include <stddef.h>
+
+/*
+ * memmem() returns the location of the first occurence of data
+ * pattern b2 of size len2 in memory block b1 of size len1 or
+ * NULL if none is found.
+ */
+void *memmem(const void *b1, size_t len1, const void *b2, size_t len2);
+
+#endif // !defined(HAVE_MEMMEM)
+
+#endif // URWEB_MEMMEM_H
diff --git a/src/c/request.c b/src/c/request.c
index 3e7ac34c..195b3cdc 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -11,13 +11,12 @@
#include <pthread.h>
+#include "memmem.h"
#include "urweb.h"
#include "request.h"
#define MAX_RETRIES 5
-void *urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2);
-
static int try_rollback(uw_context ctx, int will_retry, void *logger_data, uw_logger log_error) {
int r = uw_rollback(ctx, will_retry);
@@ -422,7 +421,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
}
}
- part = urweb_memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len);
+ part = memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len);
if (!part) {
log_error(logger_data, "Missing boundary after multipart payload\n");
return FAILED;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 78946872..6f36e3ed 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4328,7 +4328,7 @@ uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_
struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day,
.tm_hour = hour, .tm_min = minute, .tm_sec = second,
.tm_isdst = -1 };
- uw_Basis_time r = { timelocal(&tm) };
+ uw_Basis_time r = { mktime(&tm) };
return r;
}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 87d2576c..e0153944 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3783,7 +3783,13 @@ fun p_sql env (ds, _) =
end)
env ds
in
- box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
+ box ((case Settings.getFileCache () of
+ NONE => []
+ | SOME _ => case #supportsSHA512 (Settings.currentDbms ()) of
+ NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512";
+ [])
+ | SOME line => [string line, newline, newline])
+ @ string (#sqlPrefix (Settings.currentDbms ())) :: pps)
end
end
diff --git a/src/compiler.sig b/src/compiler.sig
index bcf69fd4..09c913f8 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -61,6 +61,7 @@ signature COMPILER = sig
dbms : string option,
sigFile : string option,
fileCache : string option,
+ safeGetDefault : bool,
safeGets : string list,
onError : (string * string list * string) option,
minHeap : int,
@@ -163,6 +164,7 @@ signature COMPILER = sig
val toUnpoly2 : (string, Core.file) transform
val toShake4'' : (string, Core.file) transform
val toEspecialize3 : (string, Core.file) transform
+ val toSpecialize3 : (string, Core.file) transform
val toReduce2 : (string, Core.file) transform
val toShake5 : (string, Core.file) transform
val toMarshalcheck : (string, Core.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index faf5bbe6..868dd628 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -65,6 +65,7 @@ type job = {
dbms : string option,
sigFile : string option,
fileCache : string option,
+ safeGetDefault : bool,
safeGets : string list,
onError : (string * string list * string) option,
minHeap : int,
@@ -385,6 +386,7 @@ fun institutionalizeJob (job : job) =
Settings.setMetaRules (#filterMeta job);
Option.app Settings.setProtocol (#protocol job);
Option.app Settings.setDbms (#dbms job);
+ Settings.setSafeGetDefault (#safeGetDefault job);
Settings.setSafeGets (#safeGets job);
Settings.setOnError (#onError job);
Settings.setMinHeap (#minHeap job);
@@ -470,6 +472,7 @@ fun parseUrp' accLibs fname =
dbms = NONE,
sigFile = NONE,
fileCache = NONE,
+ safeGetDefault = false,
safeGets = [],
onError = NONE,
minHeap = 0,
@@ -605,6 +608,7 @@ fun parseUrp' accLibs fname =
val dbms = ref NONE
val sigFile = ref (Settings.getSigFile ())
val fileCache = ref (Settings.getFileCache ())
+ val safeGetDefault = ref false
val safeGets = ref []
val onError = ref NONE
val minHeap = ref 0
@@ -645,6 +649,7 @@ fun parseUrp' accLibs fname =
dbms = !dbms,
sigFile = !sigFile,
fileCache = !fileCache,
+ safeGetDefault = !safeGetDefault,
safeGets = rev (!safeGets),
onError = !onError,
minHeap = !minHeap,
@@ -708,6 +713,7 @@ fun parseUrp' accLibs fname =
dbms = mergeO #2 (#dbms old, #dbms new),
sigFile = mergeO #2 (#sigFile old, #sigFile new),
fileCache = mergeO #2 (#fileCache old, #fileCache new),
+ safeGetDefault = #safeGetDefault old orelse #safeGetDefault new,
safeGets = #safeGets old @ #safeGets new,
onError = mergeO #2 (#onError old, #onError new),
minHeap = Int.max (#minHeap old, #minHeap new),
@@ -829,6 +835,7 @@ fun parseUrp' accLibs fname =
| "include" => headers := relifyA arg :: !headers
| "script" => scripts := arg :: !scripts
| "clientToServer" => clientToServer := ffiS () :: !clientToServer
+ | "safeGetDefault" => safeGetDefault := true
| "safeGet" => safeGets := arg :: !safeGets
| "effectful" => effectful := ffiS () :: !effectful
| "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
@@ -1383,8 +1390,9 @@ val toUnpoly2 = transform unpoly "unpoly2" o toShake4'
val toSpecialize2 = transform specialize "specialize2" o toUnpoly2
val toShake4'' = transform shake "shake4'" o toSpecialize2
val toEspecialize3 = transform especialize "especialize3" o toShake4''
+val toSpecialize3 = transform specialize "specialize3" o toEspecialize3
-val toReduce2 = transform reduce "reduce2" o toEspecialize3
+val toReduce2 = transform reduce "reduce2" o toSpecialize3
val toShake5 = transform shake "shake5" o toReduce2
diff --git a/src/core_util.sig b/src/core_util.sig
index 835577a3..8d295f1e 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -161,6 +161,12 @@ structure Decl : sig
decl : (Core.decl', 'state, 'abort) Search.mapfolder}
-> (Core.decl, 'state, 'abort) Search.mapfolder
+ val map : {kind : Core.kind' -> Core.kind',
+ con : Core.con' -> Core.con',
+ exp : Core.exp' -> Core.exp',
+ decl : Core.decl' -> Core.decl'}
+ -> Core.decl -> Core.decl
+
val fold : {kind : Core.kind' * 'state -> 'state,
con : Core.con' * 'state -> 'state,
exp : Core.exp' * 'state -> 'state,
diff --git a/src/core_util.sml b/src/core_util.sml
index 57ef16f7..d1d3d9c4 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -1029,6 +1029,22 @@ fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
decl = fn () => fd,
bind = fn ((), _) => ()} ()
+fun mapB {kind, con, exp, decl, bind} ctx d =
+ case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
+ con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
+ exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
+ decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
+ bind = bind} ctx d () of
+ S.Continue (d, ()) => d
+ | S.Return _ => raise Fail "CoreUtil.Decl.mapB: Impossible"
+
+fun map {kind, con, exp, decl} d =
+ mapB {kind = fn () => kind,
+ con = fn () => con,
+ exp = fn () => exp,
+ decl = fn () => decl,
+ bind = fn _ => ()} () d
+
fun fold {kind, con, exp, decl} s d =
case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
con = fn c => fn s => S.Continue (c, con (c, s)),
diff --git a/src/demo.sml b/src/demo.sml
index 1e58e2f8..eaec38bb 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -124,6 +124,7 @@ fun make' {prefix, dirname, guided} =
dbms = mergeWith #2 (#dbms combined, #dbms urp),
sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
fileCache = mergeWith #2 (#fileCache combined, #fileCache urp),
+ safeGetDefault = #safeGetDefault combined orelse #safeGetDefault urp,
safeGets = #safeGets combined @ #safeGets urp,
onError = NONE,
minHeap = 0,
diff --git a/src/monoize.sml b/src/monoize.sml
index dfa88be3..48001a13 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1540,17 +1540,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfiApp ("Basis", "dml", [(e, _)]) =>
let
+ val string = (L'.TFfi ("Basis", "string"), loc)
val (e, fm) = monoExp (env, st, fm) e
in
- ((L'.EDml (e, L'.Error), loc),
+ ((L'.ECase (e,
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ (L'.ERecord [], loc)),
+ ((L'.PVar ("cmd", string), loc),
+ (L'.EDml ((L'.ERel 0, loc), L'.Error), loc))],
+ {disc = string,
+ result = (L'.TRecord [], loc)}), loc),
fm)
end
| L.EFfiApp ("Basis", "tryDml", [(e, _)]) =>
let
+ val string = (L'.TFfi ("Basis", "string"), loc)
val (e, fm) = monoExp (env, st, fm) e
in
- ((L'.EDml (e, L'.None), loc),
+ ((L'.ECase (e,
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ (L'.ERecord [], loc)),
+ ((L'.PVar ("cmd", string), loc),
+ (L'.EDml ((L'.ERel 0, loc), L'.None), loc))],
+ {disc = string,
+ result = (L'.TRecord [], loc)}), loc),
fm)
end
@@ -1579,7 +1593,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
(case monoType env (L.TRecord changed, loc) of
- (L'.TRecord changed, _) =>
+ (L'.TRecord [], _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ val rt = (L'.TRecord [], loc)
+ in
+ ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+ (L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("e", s, s,
+ str ""), loc)), loc)), loc),
+ fm)
+ end
+ | (L'.TRecord changed, _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
val changed = map (fn (x, _) => (x, s)) changed
diff --git a/src/mysql.sml b/src/mysql.sml
index e7cad84e..768c5441 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1610,6 +1610,6 @@ val () = addDbms {name = "mysql",
nestedRelops = false,
windowFunctions = false,
supportsIsDistinctFrom = true,
- supportsSHA512 = false}
+ supportsSHA512 = NONE}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index 2b6bee8c..a33a1de4 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -1154,7 +1154,7 @@ val () = addDbms {name = "postgres",
nestedRelops = true,
windowFunctions = true,
supportsIsDistinctFrom = true,
- supportsSHA512 = true}
+ supportsSHA512 = SOME "CREATE EXTENSION pgcrypto;"}
val () = setDbms "postgres"
diff --git a/src/settings.sig b/src/settings.sig
index 29817467..a6a9c5fc 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -222,7 +222,9 @@ signature SETTINGS = sig
nestedRelops : bool,
windowFunctions : bool,
supportsIsDistinctFrom : bool,
- supportsSHA512 : bool
+ supportsSHA512 : string option (* If supported, give the SQL code to
+ * enable the feature in a particular
+ * database. *)
}
val addDbms : dbms -> unit
@@ -260,6 +262,7 @@ signature SETTINGS = sig
val getFileCache : unit -> string option
(* Which GET-able functions should be allowed to have side effects? *)
+ val setSafeGetDefault : bool -> unit
val setSafeGets : string list -> unit
val isSafeGet : string -> bool
diff --git a/src/settings.sml b/src/settings.sml
index 2e386a4f..f42df135 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -648,7 +648,7 @@ type dbms = {
nestedRelops : bool,
windowFunctions: bool,
supportsIsDistinctFrom : bool,
- supportsSHA512 : bool
+ supportsSHA512 : string option
}
val dbmses = ref ([] : dbms list)
@@ -682,7 +682,7 @@ val curDb = ref ({name = "",
nestedRelops = false,
windowFunctions = false,
supportsIsDistinctFrom = false,
- supportsSHA512 = false} : dbms)
+ supportsSHA512 = NONE} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =
@@ -729,7 +729,8 @@ fun getSigFile () = !sigFile
val fileCache = ref (NONE : string option)
fun setFileCache v =
- (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then
+ (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true
+ | SOME _ => false) then
ErrorMsg.error "The selected database engine is incompatible with file caching."
else
();
@@ -741,9 +742,11 @@ structure SS = BinarySetFn(struct
val compare = String.compare
end)
+val safeGetDefault = ref false
val safeGet = ref SS.empty
+fun setSafeGetDefault b = safeGetDefault := b
fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls)
-fun isSafeGet x = SS.member (!safeGet, x)
+fun isSafeGet x = !safeGetDefault orelse SS.member (!safeGet, x)
val onError = ref (NONE : (string * string list * string) option)
fun setOnError x = onError := x
diff --git a/src/specialize.sml b/src/specialize.sml
index 33545250..70e646e3 100644
--- a/src/specialize.sml
+++ b/src/specialize.sml
@@ -44,6 +44,7 @@ end
structure CM = BinaryMapFn(CK)
structure IM = IntBinaryMap
+structure IS = IntBinarySet
type datatyp' = {
name : int,
@@ -61,7 +62,7 @@ type state = {
count : int,
datatypes : datatyp IM.map,
constructors : int IM.map,
- decls : (string * int * string list * (string * int * con option) list) list
+ decls : (string * int * string list * (string * int * con option) list) list
}
fun kind (k, st) = (k, st)
@@ -72,6 +73,12 @@ val isOpen = U.Con.exists {kind = fn _ => false,
CRel _ => true
| _ => false}
+fun findApp (c, args) =
+ case c of
+ CApp ((c', _), arg) => findApp (c', arg :: args)
+ | CNamed n => SOME (n, args)
+ | _ => NONE
+
fun considerSpecialization (st : state, n, args, dt : datatyp) =
let
val args = map ReduceLocal.reduceCon args
@@ -132,31 +139,20 @@ fun considerSpecialization (st : state, n, args, dt : datatyp) =
end
and con (c, st : state) =
- let
- fun findApp (c, args) =
- case c of
- CApp ((c', _), arg) => findApp (c', arg :: args)
- | CNamed n => SOME (n, args)
- | _ => NONE
- in
- case findApp (c, []) of
- SOME (n, args as (_ :: _)) =>
- if List.exists isOpen args then
- (c, st)
- else
- (case IM.find (#datatypes st, n) of
- NONE => (c, st)
- | SOME dt =>
- if length args <> #params dt then
- (c, st)
- else
- let
- val (n, _, st) = considerSpecialization (st, n, args, dt)
- in
- (CNamed n, st)
- end)
- | _ => (c, st)
- end
+ case findApp (c, []) of
+ SOME (n, args as ((_, loc) :: _)) =>
+ (case IM.find (#datatypes st, n) of
+ NONE => (c, st)
+ | SOME dt =>
+ if length args <> #params dt then
+ (c, st)
+ else
+ let
+ val (n, _, st) = considerSpecialization (st, n, args, dt)
+ in
+ (CNamed n, st)
+ end)
+ | _ => (c, st)
and specCon st = U.Con.foldMap {kind = kind, con = con} st
@@ -252,6 +248,48 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
fun specialize file =
let
+ (*val () = CorePrint.debug := true
+ val () = print "SPECIALIZING\n"*)
+
+ (* Let's run around a file, finding any polymorphic uses of a datatype.
+ * However, don't count polymorphism within a datatype's own definition!
+ * To that end, we run a silly transform on the file before traversing. *)
+ val file' =
+ map (fn d =>
+ case #1 d of
+ DDatatype dts =>
+ U.Decl.map {kind = fn x => x,
+ exp = fn x => x,
+ decl = fn x => x,
+ con = fn CNamed n =>
+ if List.exists (fn (_, n', _, _) => n' = n) dts then
+ CUnit
+ else
+ CNamed n
+ | c => c} d
+ | _ => d) file
+
+ val fancyDatatypes = U.File.fold {kind = fn (_, fd) => fd,
+ exp = fn (_, fd) => fd,
+ decl = fn (_, fd) => fd,
+ con = fn (c, fd) =>
+ case c of
+ CApp (c1, c2) =>
+ if isOpen c2 then
+ case findApp (c, []) of
+ SOME (n, _) =>
+ ((*Print.preface ("Disqualifier",
+ CorePrint.p_con CoreEnv.empty (c, ErrorMsg.dummySpan));*)
+ IS.add (fd, n))
+ | NONE => fd
+ else
+ fd
+ | _ => fd}
+ IS.empty file'
+
+ (* Why did we find the polymorphism?
+ * It would be incoherent to specialize a datatype used polymorphically. *)
+
fun doDecl (d, st) =
let
(*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*)
@@ -259,23 +297,27 @@ fun specialize file =
in
case #1 d of
DDatatype dts =>
- ((case #decls st of
- [] => [d]
- | dts' => [(DDatatype (dts' @ dts), #2 d)]),
- {count = #count st,
- datatypes = foldl (fn ((x, n, xs, xnts), dts) =>
- IM.insert (dts, n,
- {name = x,
- params = length xs,
- constructors = xnts,
- specializations = CM.empty}))
- (#datatypes st) dts,
- constructors = foldl (fn ((x, n, xs, xnts), cs) =>
- foldl (fn ((_, n', _), constructors) =>
- IM.insert (constructors, n', n))
+ if List.exists (fn (_, n, _, _) => IS.member (fancyDatatypes, n)) dts then
+ ((*Print.preface ("Skipping", CorePrint.p_decl CoreEnv.empty d);*)
+ ([d], st))
+ else
+ ((case #decls st of
+ [] => [d]
+ | dts' => [(DDatatype (dts' @ dts), #2 d)]),
+ {count = #count st,
+ datatypes = foldl (fn ((x, n, xs, xnts), dts) =>
+ IM.insert (dts, n,
+ {name = x,
+ params = length xs,
+ constructors = xnts,
+ specializations = CM.empty}))
+ (#datatypes st) dts,
+ constructors = foldl (fn ((x, n, xs, xnts), cs) =>
+ foldl (fn ((_, n', _), constructors) =>
+ IM.insert (constructors, n', n))
cs xnts)
- (#constructors st) dts,
- decls = []})
+ (#constructors st) dts,
+ decls = []})
| _ =>
(case #decls st of
[] => [d]
@@ -287,10 +329,10 @@ fun specialize file =
end
val (ds, _) = ListUtil.foldlMapConcat doDecl
- {count = U.File.maxName file + 1,
- datatypes = IM.empty,
- constructors = IM.empty,
- decls = []} file
+ {count = U.File.maxName file + 1,
+ datatypes = IM.empty,
+ constructors = IM.empty,
+ decls = []} file
in
ds
end
diff --git a/src/sqlite.sml b/src/sqlite.sml
index db7052d1..0a3ae4ea 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -856,6 +856,6 @@ val () = addDbms {name = "sqlite",
nestedRelops = false,
windowFunctions = false,
supportsIsDistinctFrom = false,
- supportsSHA512 = false}
+ supportsSHA512 = NONE}
end
diff --git a/tests/emptyUpdate.ur b/tests/emptyUpdate.ur
new file mode 100644
index 00000000..0402d78a
--- /dev/null
+++ b/tests/emptyUpdate.ur
@@ -0,0 +1,6 @@
+table a : { B : int }
+
+fun main () : transaction page =
+ dml (update [[]] {} a (WHERE TRUE));
+ return <xml></xml>
+
diff --git a/tests/emptyUpdate.urp b/tests/emptyUpdate.urp
new file mode 100644
index 00000000..42cc98e2
--- /dev/null
+++ b/tests/emptyUpdate.urp
@@ -0,0 +1,4 @@
+database dbname=test
+safeGet EmptyUpdate/main
+
+emptyUpdate
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-28 05:18:49 +0000