summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:46:22 +0100
committerGravatar Simon Van Casteren <simonvancasteren@localhost.localdomain>2019-12-13 11:46:22 +0100
commit34bb8fae33a75868060838cda98bb46e0257ca0c (patch)
treec6c5c4dfbcc49444f14be479cf2d7e6501203878
parent870ce334b835614bab3f114b2aa57617f699c6be (diff)
parent2bca6e48c0ea8043c5300f4ebdefa5167e6472bf (diff)
Merge remote-tracking branch 'origin/master' into typeOf
-rw-r--r--doc/manual.tex5
-rw-r--r--include/urweb/urweb_cpp.h1
-rw-r--r--lib/js/urweb.js12
-rw-r--r--lib/ur/basis.urs16
-rw-r--r--lib/ur/datetime.ur3
-rw-r--r--lib/ur/datetime.urs1
-rw-r--r--lib/ur/json.ur183
-rw-r--r--lib/ur/json.urs10
-rw-r--r--src/c/Makefile.am2
-rw-r--r--src/c/http.c2
-rw-r--r--src/c/urweb.c36
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml80
-rw-r--r--src/compiler.sml10
-rw-r--r--src/elab_err.sig2
-rw-r--r--src/elab_err.sml6
-rw-r--r--src/elab_util.sml12
-rw-r--r--src/elaborate.sml47
-rw-r--r--src/main.mlton.sml253
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml21
-rw-r--r--src/mono_reduce.sml3
-rw-r--r--src/monoize.sml49
-rw-r--r--src/mysql.sml3
-rw-r--r--src/postgres.sml5
-rw-r--r--src/reduce_local.sml303
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml6
-rw-r--r--src/sqlite.sml3
-rw-r--r--src/urweb.grm9
-rw-r--r--tests/badkind.ur1
-rw-r--r--tests/badkind.urp3
-rw-r--r--tests/filter.urp1
-rw-r--r--tests/html5_cforms.ur4
-rw-r--r--tests/rpc_unit.ur8
-rw-r--r--tests/tooEager.ur18
-rw-r--r--tests/trgm.ur25
-rw-r--r--tests/trgm.urp6
-rw-r--r--tests/trgm.urs1
-rw-r--r--tests/wildsig.ur7
40 files changed, 790 insertions, 374 deletions
diff --git a/doc/manual.tex b/doc/manual.tex
index ba53f5d8..64fe0f24 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -238,6 +238,10 @@ Further \cd{urweb} invocations in the same working directory will send requests
\begin{verbatim}
urweb daemon stop
\end{verbatim}
+To restart a running (or crashed) daemon, run
+\begin{verbatim}
+urweb daemon restart
+\end{verbatim}
Communication happens via a UNIX domain socket in file \cd{.urweb\_daemon} in the working directory.
\medskip
@@ -2573,6 +2577,7 @@ It is possible to write JavaScript FFI code that interacts with the functional-r
\item \cd{sr(v)} and \cd{sb(s, f)}, the ``return'' and ``bind'' monad operators, respectively
\item \cd{ss(s)}, to produce the signal corresponding to source \cd{s}
\item \cd{scur(s)}, to get the current value of signal \cd{s}
+ \item \cd{listen(s, f)}, to ask that function \cd{f} be called with the current value of \cd{s}, every time it changes, including immediately upon establishing this listener
\end{itemize}
\item The behavior of the \cd{<dyn>} pseudo-tag may be mimicked by following the right convention in a piece of HTML source code with a type like $\mt{xbody}$. Such a piece of source code may be encoded with a JavaScript string. To insert a dynamic section, include a \cd{<script>} tag whose content is just a call \cd{dyn(pnode, s)}. The argument \cd{pnode} specifies what the relevant enclosing parent tag is. Use value \cd{"tr"} when the immediate parent is \cd{<tr>}, use \cd{"table"} when the immediate parent is \cd{<table>}, and use \cd{"span"} otherwise. The argument \cd{s} is a string-valued signal giving the HTML code to be inserted at this point. As with the usual \cd{<dyn>} tag, that HTML subtree is automatically updated as the value of \cd{s} changes.
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index dcf67fef..e4ad6e61 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -166,6 +166,7 @@ uw_Basis_string uw_Basis_strchr(struct uw_context *, const char *, uw_Basis_char
uw_Basis_int uw_Basis_strcspn(struct uw_context *, const char *, const char *);
uw_Basis_string uw_Basis_substring(struct uw_context *, const char *, uw_Basis_int, uw_Basis_int);
uw_Basis_string uw_Basis_str1(struct uw_context *, uw_Basis_char);
+uw_Basis_string uw_Basis_ofUnicode(struct uw_context *, uw_Basis_int);
uw_Basis_string uw_strdup(struct uw_context *, const char *);
uw_Basis_string uw_maybe_strdup(struct uw_context *, const char *);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 66d427c8..59e5ad2c 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -2135,6 +2135,16 @@ function active(s) {
}
}
+function listen(s, onchange) {
+ var x = document.createElement("script");
+ x.dead = false;
+ x.signal = s;
+ x.sources = null;
+ x.closures = null;
+ x.recreate = onchange;
+ populate(x);
+}
+
function input(x, s, recreate, type, name) {
if (name) x.name = name;
if (type) x.type = type;
@@ -3270,7 +3280,7 @@ function confrm(s) {
}
function currentUrl() {
- return window.location;
+ return window.location.toString();
}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index be13c684..dda48d2b 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -95,6 +95,7 @@ val strsindex : string -> string -> option int
val strcspn : string -> string -> int
val substring : string -> int -> int -> string
val str1 : char -> string
+val ofUnicode : int -> string
class show
val show : t ::: Type -> show t -> t -> string
@@ -571,9 +572,6 @@ val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t
val sql_mod : sql_binary int int int
val sql_eq : t ::: Type -> sql_binary t t bool
-(* Note that the semantics of this operator on nullable types are different than for standard SQL!
- * Instead, we do it the sane way, where [NULL = NULL]. *)
-
val sql_ne : t ::: Type -> sql_binary t t bool
val sql_lt : t ::: Type -> sql_binary t t bool
val sql_le : t ::: Type -> sql_binary t t bool
@@ -625,6 +623,16 @@ val sql_known : t ::: Type -> sql_ufunc t bool
val sql_lower : sql_ufunc string string
val sql_upper : sql_ufunc string string
+con sql_bfunc :: Type -> Type -> Type -> Type
+val sql_bfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+ -> dom1 ::: Type -> dom2 ::: Type -> ran ::: Type
+ -> sql_bfunc dom1 dom2 ran
+ -> sql_exp tables agg exps dom1
+ -> sql_exp tables agg exps dom2
+ -> sql_exp tables agg exps ran
+val sql_similarity : sql_bfunc string string float
+(* Only supported by Postgres for now, via the pg_trgm module *)
+
val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-> sql_injectable_prim t
-> sql_exp tables agg exps t
@@ -1076,7 +1084,7 @@ val ctel : ctext
val ccolor : ctext
val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) []
-val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) []
+val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Step = float] ++ boxAttrs ++ inputAttrs) []
val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) []
val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) []
val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) []
diff --git a/lib/ur/datetime.ur b/lib/ur/datetime.ur
index 9aeab291..99fd5a7d 100644
--- a/lib/ur/datetime.ur
+++ b/lib/ur/datetime.ur
@@ -88,7 +88,8 @@ fun intToMonth i = case i of
| n => error <xml>Invalid month number {[n]}</xml>
val eq_month = mkEq (fn a b => monthToInt a = monthToInt b)
-
+val ord_month = mkOrd {Lt = fn a b => monthToInt a < monthToInt b,
+ Le = fn a b => monthToInt a <= monthToInt b}
fun toTime dt : time = fromDatetime dt.Year (monthToInt dt.Month) dt.Day
dt.Hour dt.Minute dt.Second
diff --git a/lib/ur/datetime.urs b/lib/ur/datetime.urs
index 972f86bf..f8460443 100644
--- a/lib/ur/datetime.urs
+++ b/lib/ur/datetime.urs
@@ -20,6 +20,7 @@ val show_day_of_week : show day_of_week
val show_month : show month
val eq_day_of_week : eq day_of_week
val eq_month : eq month
+val ord_month : ord month
val dayOfWeekToInt : day_of_week -> int
val intToDayOfWeek : int -> day_of_week
val monthToInt : month -> int
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
index 05406739..58822d4b 100644
--- a/lib/ur/json.ur
+++ b/lib/ur/json.ur
@@ -59,42 +59,71 @@ fun escape s =
"\"" ^ esc s
end
+fun unhex ch =
+ if Char.isDigit ch then
+ Char.toInt ch - Char.toInt #"0"
+ else if Char.isXdigit ch then
+ if Char.isUpper ch then
+ 10 + (Char.toInt ch - Char.toInt #"A")
+ else
+ 10 + (Char.toInt ch - Char.toInt #"a")
+ else
+ error <xml>Invalid hexadecimal digit "{[ch]}"</xml>
+
fun unescape s =
let
val len = String.length s
- fun findEnd i =
+ fun findEnd i s =
if i >= len then
error <xml>JSON unescape: string ends before quote: {[s]}</xml>
else
let
- val ch = String.sub s i
+ val ch = String.sub s 0
in
case ch of
#"\"" => i
| #"\\" =>
if i+1 >= len then
error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else if String.sub s 1 = #"u" then
+ if i+5 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ findEnd (i+6) (String.suffix s 6)
else
- findEnd (i+2)
- | _ => findEnd (i+1)
+ findEnd (i+2) (String.suffix s 2)
+ | _ => findEnd (i+1) (String.suffix s 1)
end
- val last = findEnd 1
+ val last = findEnd 1 (String.suffix s 1)
- fun unesc i =
+ fun unesc i s =
if i >= last then
""
else
let
- val ch = String.sub s i
+ val ch = String.sub s 0
in
case ch of
#"\\" =>
if i+1 >= len then
error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else if String.sub s 1 = #"u" then
+ if i+5 >= len then
+ error <xml>JSON unescape: Unicode ends early</xml>
+ else
+ let
+ val n =
+ unhex (String.sub s 2) * (256*16)
+ + unhex (String.sub s 3) * 256
+ + unhex (String.sub s 4) * 16
+ + unhex (String.sub s 5)
+ in
+ ofUnicode n ^ unesc (i+6) (String.suffix s 6)
+ end
else
- (case String.sub s (i+1) of
+ (case String.sub s 1 of
#"n" => "\n"
| #"r" => "\r"
| #"t" => "\t"
@@ -103,19 +132,66 @@ fun unescape s =
| #"/" => "/"
| x => error <xml>JSON unescape: Bad escape char: {[x]}</xml>)
^
- unesc (i+2)
- | _ => String.str ch ^ unesc (i+1)
+ unesc (i+2) (String.suffix s 2)
+ | _ => String.str ch ^ unesc (i+1) (String.suffix s 1)
end
in
if len = 0 || String.sub s 0 <> #"\"" then
error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml>
else
- (unesc 1, String.substring s {Start = last+1, Len = len-last-1})
+ (unesc 1 (String.suffix s 1), String.suffix s (last+1))
end
val json_string = {ToJson = escape,
FromJson = unescape}
+fun rfc3339_out s =
+ let
+ val out1 = timef "%Y-%m-%dT%H:%M:%S%z" s
+ val len = String.length out1
+ in
+ if len < 2 then
+ error <xml>timef output too short</xml>
+ else
+ String.substring out1 {Start = 0, Len = len - 2} ^ ":"
+ ^ String.suffix out1 (len - 2)
+ end
+
+fun rfc3339_in s =
+ case String.split s #"T" of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (date, time) =>
+ case String.msplit {Haystack = time, Needle = "Z+-"} of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (time, sep, rest) =>
+ let
+ val t = case readUtc (date ^ " " ^ time) of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some t => t
+
+ fun withOffset multiplier =
+ case String.split rest #":" of
+ None => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ | Some (h, m) =>
+ case (read h, read m) of
+ (Some h, Some m) => addSeconds t (multiplier * 60 * (60 * h + m))
+ | _ => error <xml>Invalid RFC 3339 string "{[s]}"</xml>
+ in
+ case sep of
+ #"Z" => t
+ | #"+" => withOffset (-1)
+ | #"-" => withOffset 1
+ | _ => error <xml>msplit returns impossible separator</xml>
+ end
+
+val json_time = {ToJson = fn tm => escape (rfc3339_out tm),
+ FromJson = fn s =>
+ let
+ val (v, s') = unescape s
+ in
+ (rfc3339_in v, s')
+ end}
+
fun numIn [a] (_ : read a) s : a * string =
let
val len = String.length s
@@ -258,6 +334,91 @@ fun skipOne s =
skipOne s False False 0 0
end
+fun json_record_withOptional [ts ::: {Type}] [ots ::: {Type}] [ts ~ ots]
+ (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts))
+ (ofl : folder ots) (ojss : $(map json ots)) (onames : $(map (fn _ => string) ots)): json $(ts ++ map option ots) =
+ {ToJson = fn r =>
+ let
+ val withRequired =
+ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ "" fl jss names (r --- _)
+
+ val withOptional =
+ @foldR3 [json] [fn _ => string] [option] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ case v of
+ None => acc
+ | Some v =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ "" ofl ojss onames (r --- _)
+ in
+ "{" ^ withOptional ^ "}"
+ end,
+ FromJson = fn s =>
+ let
+ fun fromJ s (r : $(map option (ts ++ ots))) : $(map option (ts ++ ots)) * string =
+ if String.length s = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s 0 = #"}" then
+ (r, String.substring s {Start = 1, Len = String.length s - 1})
+ else let
+ val (name, s') = unescape s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r =>
+ if name = name' then
+ let
+ val (v, s') = j.FromJson s'
+ in
+ (r -- nm ++ {nm = Some v}, s')
+ end
+ else
+ let
+ val (r', s') = acc (r -- nm)
+ in
+ (r' ++ {nm = r.nm}, s')
+ end)
+ (fn r => (r, skipOne s'))
+ (@Folder.concat ! fl ofl) (jss ++ ojss) (names ++ onames) r
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ fromJ s' r
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON record doesn't begin with brace</xml>
+ else
+ let
+ val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ (@map0 [option] (fn [t ::_] => None) (@Folder.concat ! fl ofl))
+ in
+ (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name =>
+ case v of
+ None => error <xml>Missing JSON object field {[name]}</xml>
+ | Some v => v) fl (r --- _) names
+ ++ (r --- _), s')
+ end
+end}
+
+(* At the moment, the below code is largely copied and pasted from the last
+ * definition, because otherwise the compiler fails to inline enough for
+ * compilation to succeed. *)
fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts =
{ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
(fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
diff --git a/lib/ur/json.urs b/lib/ur/json.urs
index b4bd6350..ad49a40f 100644
--- a/lib/ur/json.urs
+++ b/lib/ur/json.urs
@@ -13,10 +13,20 @@ val json_string : json string
val json_int : json int
val json_float : json float
val json_bool : json bool
+val json_time : json time
val json_option : a ::: Type -> json a -> json (option a)
val json_list : a ::: Type -> json a -> json (list a)
+(* By the way, time formatting follows RFC 3339, and we expose the more
+ * primitive formatting functions here. *)
+val rfc3339_out : time -> string
+val rfc3339_in : string -> time
+
val json_record : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json $ts
+val json_record_withOptional : ts ::: {Type} -> ots ::: {Type} -> [ts ~ ots]
+ => folder ts -> $(map json ts) -> $(map (fn _ => string) ts)
+ -> folder ots -> $(map json ots) -> $(map (fn _ => string) ots)
+ -> json $(ts ++ map option ots)
val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts)
val json_unit : json unit
diff --git a/src/c/Makefile.am b/src/c/Makefile.am
index 95582793..ff4b6eaf 100644
--- a/src/c/Makefile.am
+++ b/src/c/Makefile.am
@@ -11,7 +11,7 @@ AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecate
liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \
-export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' \
-version-info 1:0:0
-liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata
+liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata -licuio
liburweb_http_la_LIBADD = liburweb.la
liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \
-version-info 1:0:0
diff --git a/src/c/http.c b/src/c/http.c
index 68c16e0b..c1fccf4a 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -65,6 +65,7 @@ static void log_error(void *data, const char *fmt, ...) {
va_start(ap, fmt);
vfprintf(stderr, fmt, ap);
+ fflush(stderr);
}
static void log_debug(void *data, const char *fmt, ...) {
@@ -75,6 +76,7 @@ static void log_debug(void *data, const char *fmt, ...) {
va_start(ap, fmt);
vprintf(fmt, ap);
+ fflush(stdout);
}
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index b820354f..a01b4aae 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -21,6 +21,7 @@
#include <pthread.h>
#include <unicode/utf8.h>
+#include <unicode/ustring.h>
#include <unicode/uchar.h>
#include "types.h"
@@ -2344,10 +2345,23 @@ char *uw_Basis_htmlifySpecialChar(uw_context ctx, uw_Basis_char ch) {
uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) {
unsigned int n = ch;
- int len;
+ int len = 0;
uw_check(ctx, INTS_MAX+3);
- len = sprintf(ctx->page.front, "&#%u;", n);
+
+ if(uw_Basis_isprint(ctx, ch)) {
+
+ int32_t len_written = 0;
+ UErrorCode err = U_ZERO_ERROR;
+
+ u_strToUTF8(ctx->page.front, 5, &len_written, (const UChar*)&ch, 1, &err);
+ len = len_written;
+ }
+
+ // either it's a non-printable character, or we failed to convert to UTF-8
+ if(len == 0) {
+ len = sprintf(ctx->page.front, "&#%u;", n);
+ }
ctx->page.front += len;
return uw_unit_v;
@@ -2459,7 +2473,7 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) {
else {
uw_Basis_htmlifySpecialChar_w(ctx, c1);
}
- }
+ }
return uw_unit_v;
}
@@ -2710,6 +2724,18 @@ uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) {
return r;
}
+uw_Basis_string uw_Basis_ofUnicode(uw_context ctx, uw_Basis_int n) {
+ UChar buf16[] = {n};
+ uw_Basis_string out = uw_malloc(ctx, 3);
+ int32_t outLen;
+ UErrorCode pErrorCode = 0;
+
+ if (u_strToUTF8(out, 3, &outLen, buf16, 1, &pErrorCode) == NULL || outLen == 0)
+ uw_error(ctx, FATAL, "Bad Unicode string to unescape (error %s)", u_errorName(pErrorCode));
+
+ return out;
+}
+
uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) {
int len = strlen(s1) + 1;
char *s;
@@ -4915,13 +4941,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) {
f = uw_malloc(ctx, sizeof(uw_Basis_postField));
unurl = s;
- f->name = uw_Basis_unurlifyString(ctx, &unurl);
+ f->name = uw_Basis_unurlifyString_fromClient(ctx, &unurl);
s = strchr(s, 0);
if (!s)
uw_error(ctx, FATAL, "firstFormField: Missing null terminator");
++s;
unurl = s;
- f->value = uw_Basis_unurlifyString(ctx, &unurl);
+ f->value = uw_Basis_unurlifyString_fromClient(ctx, &unurl);
s = strchr(s, 0);
if (!s)
uw_error(ctx, FATAL, "firstFormField: Missing null terminator");
diff --git a/src/cjr.sml b/src/cjr.sml
index e582e6ae..9b154428 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -115,7 +115,7 @@ datatype decl' =
| DTable of string * (string * typ) list * string * (string * string) list
| DSequence of string
| DView of string * (string * typ) list * string
- | DDatabase of {name : string, expunge : int, initialize : int}
+ | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool}
| DPreparedStatements of (string * int) list
| DJavaScript of string
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 5dcfbe89..70ebdf43 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1014,52 +1014,39 @@ fun urlify env t =
let
fun urlify' level (t as (_, loc)) =
case #1 t of
- TFfi ("Basis", "unit") => box []
+ TFfi ("Basis", "unit") => box [string "uw_Basis_urlifyString_w(ctx, \"\");",
+ newline]
| TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
^ "_w(ctx, it" ^ Int.toString level ^ ");"),
newline]
- | TRecord 0 => box []
+ | TRecord 0 => box [string "uw_Basis_urlifyString_w(ctx, \"\");",
+ newline]
| TRecord i =>
let
- fun empty (t, _) =
- case t of
- TFfi ("Basis", "unit") => true
- | TRecord 0 => true
- | TRecord j =>
- List.all (fn (_, t) => empty t) (E.lookupStruct env j)
- | _ => false
-
val xts = E.lookupStruct env i
val (blocks, _) = foldl
(fn ((x, t), (blocks, printingSinceLastSlash)) =>
- let
- val thisEmpty = empty t
- in
- if thisEmpty then
- (blocks, printingSinceLastSlash)
- else
- (box [string "{",
- newline,
- p_typ env t,
- space,
- string ("it" ^ Int.toString (level + 1)),
- space,
- string "=",
- space,
- string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
- newline,
- box (if printingSinceLastSlash then
- [string "uw_write(ctx, \"/\");",
- newline]
- else
- []),
- urlify' (level + 1) t,
- string "}",
- newline] :: blocks,
- true)
- end)
+ (box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string ("it" ^ Int.toString (level + 1)),
+ space,
+ string "=",
+ space,
+ string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
+ newline,
+ box (if printingSinceLastSlash then
+ [string "uw_write(ctx, \"/\");",
+ newline]
+ else
+ []),
+ urlify' (level + 1) t,
+ string "}",
+ newline] :: blocks,
+ true))
([], false) xts
in
box (rev blocks)
@@ -3243,10 +3230,11 @@ fun p_file env (ds, ps) =
val _ = foldl (fn (d, env) =>
((case #1 d of
- DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
- dbstring := x;
- expunge := y;
- initialize := z)
+ DDatabase {name = x, expunge = y, initialize = z, ...} =>
+ (hasDb := true;
+ dbstring := x;
+ expunge := y;
+ initialize := z)
| DJavaScript _ => hasJs := true
| DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
(x, sql_type_in env t)) xts) :: !tables
@@ -3766,6 +3754,8 @@ fun declaresAsForeignKey xs s =
fun p_sql env (ds, _) =
let
+ val usesSimilar = ref false
+
val (pps, _) = ListUtil.foldlMap
(fn (dAll as (d, _), env) =>
let
@@ -3850,6 +3840,9 @@ fun p_sql env (ds, _) =
string ";",
newline,
newline]
+ | DDatabase {usesSimilar = s, ...} =>
+ (usesSimilar := s;
+ box [])
| _ => box []
in
(pp, E.declBinds env dAll)
@@ -3862,6 +3855,13 @@ fun p_sql env (ds, _) =
NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512";
[])
| SOME r => [string (#InitializeDb r), newline, newline])
+ @ (if !usesSimilar then
+ case #supportsSimilar (Settings.currentDbms ()) of
+ NONE => (ErrorMsg.error "Using SIMILAR with database that doesn't support it";
+ [])
+ | SOME r => [string (#InitializeDb r), newline, newline]
+ else
+ [])
@ string (#sqlPrefix (Settings.currentDbms ())) :: pps)
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 0aba3a40..fab939f9 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -745,7 +745,7 @@ fun parseUrp' accLibs fname =
| "relation" => Settings.Relation
| "cookie" => Settings.Cookie
| "style" => Settings.Style
- | _ => (ErrorMsg.error "Bad path kind spec";
+ | _ => (ErrorMsg.error ("Bad path kind spec \"" ^ s ^ "\"");
Settings.Any)
fun parsePattern s =
@@ -1610,9 +1610,13 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} =
val proto = Settings.currentProtocol ()
val lib = if Settings.getBootLinking () then
- !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata"
+ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^
+ !Settings.configLib ^ "/liburweb.a " ^
+ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio"
else if Settings.getStaticLinking () then
- " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata"
+ " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic
+ proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^
+ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio"
else
"-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb"
diff --git a/src/elab_err.sig b/src/elab_err.sig
index acf137df..fc80fcac 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -29,6 +29,7 @@ signature ELAB_ERR = sig
datatype kind_error =
UnboundKind of ErrorMsg.span * string
+ | KDisallowedWildcard of ErrorMsg.span
val kindError : ElabEnv.env -> kind_error -> unit
@@ -47,6 +48,7 @@ signature ELAB_ERR = sig
| DuplicateField of ErrorMsg.span * string
| ProjBounds of Elab.con * int
| ProjMismatch of Elab.con * Elab.kind
+ | CDisallowedWildcard of ErrorMsg.span
val conError : ElabEnv.env -> con_error -> unit
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 385caca3..bbe1c160 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -40,11 +40,14 @@ val p_kind = P.p_kind
datatype kind_error =
UnboundKind of ErrorMsg.span * string
+ | KDisallowedWildcard of ErrorMsg.span
fun kindError env err =
case err of
UnboundKind (loc, s) =>
ErrorMsg.errorAt loc ("Unbound kind variable " ^ s)
+ | KDisallowedWildcard loc =>
+ ErrorMsg.errorAt loc "Wildcard not allowed in signature"
datatype kunify_error =
KOccursCheckFailed of kind * kind
@@ -76,6 +79,7 @@ datatype con_error =
| DuplicateField of ErrorMsg.span * string
| ProjBounds of con * int
| ProjMismatch of con * kind
+ | CDisallowedWildcard of ErrorMsg.span
fun conError env err =
case err of
@@ -101,6 +105,8 @@ fun conError env err =
(ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor";
eprefaces' [("Constructor", p_con env c),
("Kind", p_kind env k)])
+ | CDisallowedWildcard loc =>
+ ErrorMsg.errorAt loc "Wildcard not allowed in signature"
datatype cunify_error =
CKind of kind * kind * E.env * kunify_error
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 0cdb9cc1..aa5bc6a4 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -541,11 +541,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
and mfed ctx (dAll as (d, loc)) =
case d of
EDVal (p, t, e) =>
- S.bind2 (mfc ctx t,
- fn t' =>
- S.map2 (mfe ctx e,
- fn e' =>
- (EDVal (p, t', e'), loc)))
+ S.bind2 (mfp ctx p,
+ fn p' =>
+ S.bind2 (mfc ctx t,
+ fn t' =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EDVal (p', t', e'), loc))))
| EDValRec vis =>
let
val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 1c76250f..d5e190fa 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -260,6 +260,21 @@
end
+ (* Wildcards are disallowed inside signatures.
+ * We use a flag to indicate when we are in a signature,
+ * with a helper function for entering this mode and properly backing out afterward. *)
+ val inSignature = ref false
+ fun enterSignature' b f =
+ let
+ val inS = !inSignature
+ in
+ inSignature := b;
+ (f () handle ex => (inSignature := inS; raise ex))
+ before inSignature := inS
+ end
+ fun enterSignature f = enterSignature' true f
+ fun exitSignature f = enterSignature' false f
+
fun elabKind env (k, loc) =
case k of
L.KType => (L'.KType, loc)
@@ -268,7 +283,7 @@
| L.KRecord k => (L'.KRecord (elabKind env k), loc)
| L.KUnit => (L'.KUnit, loc)
| L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc)
- | L.KWild => kunif env loc
+ | L.KWild => if !inSignature then (kindError env (KDisallowedWildcard loc); kerror) else kunif env loc
| L.KVar s => (case E.lookupK env s of
NONE =>
@@ -531,11 +546,15 @@
end
| L.CWild k =>
- let
- val k' = elabKind env k
- in
- (cunif env (loc, k'), k', [])
- end
+ if !inSignature then
+ (conError env (CDisallowedWildcard loc);
+ (cerror, kerror, []))
+ else
+ let
+ val k' = elabKind env k
+ in
+ (cunif env (loc, k'), k', [])
+ end
fun kunifsRemain k =
case k of
@@ -2560,7 +2579,10 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
let
val k' = case ko of
NONE => kunif env loc
- | SOME k => elabKind env k
+ | SOME k => exitSignature (fn () => elabKind env k)
+ (* Waive wildcard restriction within translation
+ * of kind annotation. The kind of [c] will allow
+ * us to resolve it fully. *)
val (c', ck, gs') = elabCon (env, denv) c
val (env', n) = E.pushCNamed env x k' (SOME c')
@@ -2712,7 +2734,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
val ct = (L'.CApp (ct, c'), loc)
val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc)
- val (pe', pet, gs'') = elabExp (env', denv) pe
+ val (pe', pet, gs'') = exitSignature (fn () => elabExp (env', denv) pe)
val gs'' = List.mapPartial (fn Disjoint x => SOME x
| _ => NONE) gs''
@@ -2720,7 +2742,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
val pst = (L'.CApp (pst, c'), loc)
val pst = (L'.CApp (pst, pkey), loc)
- val (ce', cet, gs''') = elabExp (env', denv) ce
+ val (ce', cet, gs''') = exitSignature (fn () => elabExp (env', denv) ce)
val gs''' = List.mapPartial (fn Disjoint x => SOME x
| _ => NONE) gs'''
@@ -4146,7 +4168,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
| L.DSgn (x, sgn) =>
let
- val (sgn', gs') = elabSgn (env, denv) sgn
+ val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn)
val (env', n) = E.pushSgnNamed env x sgn'
in
([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs))
@@ -4172,7 +4194,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
else
()
- val formal = Option.map (elabSgn (env, denv)) sgno
+ val formal = enterSignature (fn () => Option.map (elabSgn (env, denv)) sgno)
val (str', sgn', gs') =
case formal of
@@ -4227,7 +4249,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
let
val () = ErrorMsg.startElabStructure x
- val (sgn', gs') = elabSgn (env, denv) sgn
+ val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn)
val (env', n) = E.pushStrNamed env x sgn'
@@ -4747,6 +4769,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
val () = mayDelay := true
val () = delayedUnifs := []
val () = delayedExhaustives := []
+ val () = inSignature := false
val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan)
val (basis_n, env', sgn) =
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index bbee8c90..7f8540f2 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -107,6 +107,8 @@ fun usage flag_info =
(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
+exception DaemonExit
+
fun oneRun args =
let
val timing = ref false
@@ -261,7 +263,8 @@ fun oneRun args =
]
val () = case args of
- ["daemon", "stop"] => OS.Process.exit OS.Process.success
+ ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => ();
+ raise DaemonExit)
| _ => ()
val sources = parse_flags (flag_info ()) args
@@ -324,128 +327,138 @@ fun send (sock, s) =
send (sock, String.extract (s, n, NONE))
end
-val () = (Globals.setResetTime ();
- case CommandLine.arguments () of
- ["daemon", "start"] =>
- (case Posix.Process.fork () of
- SOME _ => ()
- | NONE =>
- let
- val () = Elaborate.incremental := true
- val listen = UnixSock.Strm.socket ()
-
- fun loop () =
- let
- val (sock, _) = Socket.accept listen
-
- fun loop' (buf, args) =
- let
- val s = if CharVector.exists (fn ch => ch = #"\n") buf then
- ""
- else
- MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024))))
- val s = buf ^ s
- val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
- in
- if Substring.isEmpty after then
- loop' (s, args)
- else
- let
- val cmd = Substring.string befor
- val rest = Substring.string (Substring.slice (after, 1, NONE))
- in
- case cmd of
- "" =>
- (case args of
- ["stop", "daemon"] =>
- (((Socket.close listen;
- OS.FileSys.remove socket) handle OS.SysErr _ => ());
- OS.Process.exit OS.Process.success)
- | _ =>
- let
- val success = (oneRun (rev args))
- handle ex => (print "unhandled exception:\n";
- print (General.exnMessage ex ^ "\n");
- OS.Process.failure)
- in
- TextIO.flushOut TextIO.stdOut;
- TextIO.flushOut TextIO.stdErr;
- send (sock, if OS.Process.isSuccess success then
- "\001"
- else
- "\002")
- end)
- | _ => loop' (rest, cmd :: args)
- end
- end handle OS.SysErr _ => ()
-
- fun redirect old =
- Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
- new = old}
-
- val oldStdout = Posix.IO.dup Posix.FileSys.stdout
- val oldStderr = Posix.IO.dup Posix.FileSys.stderr
- in
- (* Redirect the daemon's output to the socket. *)
- redirect Posix.FileSys.stdout;
- redirect Posix.FileSys.stderr;
-
- loop' ("", []);
- Socket.close sock;
-
- Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
- Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
- Posix.IO.close oldStdout;
- Posix.IO.close oldStderr;
-
- Settings.reset ();
- MLton.GC.pack ();
- loop ()
- end
- in
- OS.Process.atExit (fn () => OS.FileSys.remove socket);
- Socket.bind (listen, UnixSock.toAddr socket);
- Socket.listen (listen, 1);
- loop ()
- end)
- | args =>
+fun startDaemon () =
+ if OS.FileSys.access (socket, []) then
+ (print ("It looks like a daemon is already listening in this directory,\n"
+ ^ "though it's possible a daemon died without cleaning up its socket.\n");
+ OS.Process.exit OS.Process.failure)
+ else case Posix.Process.fork () of
+ SOME _ => ()
+ | NONE =>
let
- val sock = UnixSock.Strm.socket ()
+ val () = Elaborate.incremental := true
+ val listen = UnixSock.Strm.socket ()
- fun wait () =
+ fun loop () =
let
- val v = Socket.recvVec (sock, 1024)
- in
- if Word8Vector.length v = 0 then
- OS.Process.failure
- else
+ val (sock, _) = Socket.accept listen
+
+ fun loop' (buf, args) =
let
- val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v))
- val last = Word8Vector.sub (v, Word8Vector.length v - 1)
- val (rc, s) = if last = Word8.fromInt 1 then
- (SOME OS.Process.success, String.substring (s, 0, size s - 1))
- else if last = Word8.fromInt 2 then
- (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
- else
- (NONE, s)
+ val s = if CharVector.exists (fn ch => ch = #"\n") buf then
+ ""
+ else
+ MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024))))
+ val s = buf ^ s
+ val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
in
- print s;
- case rc of
- NONE => wait ()
- | SOME rc => rc
- end
- end handle OS.SysErr _ => OS.Process.failure
+ if Substring.isEmpty after then
+ loop' (s, args)
+ else
+ let
+ val cmd = Substring.string befor
+ val rest = Substring.string (Substring.slice (after, 1, NONE))
+ in
+ case cmd of
+ "" =>
+ (case args of
+ ["stop", "daemon"] =>
+ (((Socket.close listen;
+ OS.FileSys.remove socket) handle OS.SysErr _ => ());
+ OS.Process.exit OS.Process.success)
+ | _ =>
+ let
+ val success = (oneRun (rev args) handle DaemonExit => OS.Process.exit OS.Process.success)
+ handle ex => (print "unhandled exception:\n";
+ print (General.exnMessage ex ^ "\n");
+ OS.Process.failure)
+ in
+ TextIO.flushOut TextIO.stdOut;
+ TextIO.flushOut TextIO.stdErr;
+ send (sock, if OS.Process.isSuccess success then
+ "\001"
+ else
+ "\002")
+ end)
+ | _ => loop' (rest, cmd :: args)
+ end
+ end handle OS.SysErr _ => ()
+
+ fun redirect old =
+ Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
+ new = old}
+
+ val oldStdout = Posix.IO.dup Posix.FileSys.stdout
+ val oldStderr = Posix.IO.dup Posix.FileSys.stderr
+ in
+ (* Redirect the daemon's output to the socket. *)
+ redirect Posix.FileSys.stdout;
+ redirect Posix.FileSys.stderr;
+
+ loop' ("", []);
+ Socket.close sock;
+
+ Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
+ Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
+ Posix.IO.close oldStdout;
+ Posix.IO.close oldStderr;
+
+ Settings.reset ();
+ MLton.GC.pack ();
+ loop ()
+ end
in
- if Socket.connectNB (sock, UnixSock.toAddr socket)
- orelse not (List.null (#wrs (Socket.select {rds = [],
- wrs = [Socket.sockDesc sock],
- exs = [],
- timeout = SOME (Time.fromSeconds 1)}))) then
- (app (fn arg => send (sock, arg ^ "\n")) args;
- send (sock, "\n");
- OS.Process.exit (wait ()))
- else
- (OS.FileSys.remove socket;
- raise OS.SysErr ("", NONE))
- end handle OS.SysErr _ =>
- OS.Process.exit (oneRun args))
+ OS.Process.atExit (fn () => OS.FileSys.remove socket);
+ Socket.bind (listen, UnixSock.toAddr socket);
+ Socket.listen (listen, 1);
+ loop ()
+ end
+
+fun oneCommandLine args =
+ let
+ val sock = UnixSock.Strm.socket ()
+
+ fun wait () =
+ let
+ val v = Socket.recvVec (sock, 1024)
+ in
+ if Word8Vector.length v = 0 then
+ OS.Process.failure
+ else
+ let
+ val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v))
+ val last = Word8Vector.sub (v, Word8Vector.length v - 1)
+ val (rc, s) = if last = Word8.fromInt 1 then
+ (SOME OS.Process.success, String.substring (s, 0, size s - 1))
+ else if last = Word8.fromInt 2 then
+ (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
+ else
+ (NONE, s)
+ in
+ print s;
+ case rc of
+ NONE => wait ()
+ | SOME rc => rc
+ end
+ end handle OS.SysErr _ => OS.Process.failure
+ in
+ if Socket.connectNB (sock, UnixSock.toAddr socket)
+ orelse not (List.null (#wrs (Socket.select {rds = [],
+ wrs = [Socket.sockDesc sock],
+ exs = [],
+ timeout = SOME (Time.fromSeconds 1)}))) then
+ (app (fn arg => send (sock, arg ^ "\n")) args;
+ send (sock, "\n");
+ wait ())
+ else
+ (OS.FileSys.remove socket;
+ raise OS.SysErr ("", NONE))
+ end handle OS.SysErr _ => oneRun args handle DaemonExit => OS.Process.success
+
+val () = (Globals.setResetTime ();
+ case CommandLine.arguments () of
+ ["daemon", "start"] => startDaemon ()
+ | ["daemon", "restart"] =>
+ (ignore (oneCommandLine ["daemon", "stop"]);
+ startDaemon ())
+ | args => OS.Process.exit (oneCommandLine args))
diff --git a/src/mono.sml b/src/mono.sml
index cdadded5..754fe283 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -142,7 +142,7 @@ datatype decl' =
| DTable of string * (string * typ) list * exp * exp
| DSequence of string
| DView of string * (string * typ) list * exp
- | DDatabase of {name : string, expunge : int, initialize : int}
+ | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool}
| DJavaScript of string
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a3b55ec0..1114a4f0 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -509,16 +509,17 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e,
string "*)"]
- | DDatabase {name, expunge, initialize} => box [string "database",
- space,
- string name,
- space,
- string "(",
- p_enamed env expunge,
- string ",",
- space,
- p_enamed env initialize,
- string ")"]
+ | DDatabase {name, expunge, initialize, ...} =>
+ box [string "database",
+ space,
+ string name,
+ space,
+ string "(",
+ p_enamed env expunge,
+ string ",",
+ space,
+ p_enamed env initialize,
+ string ")"]
| DJavaScript s => box [string "JavaScript(",
string s,
string ")"]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5bcb6f57..c3c9da98 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -597,8 +597,7 @@ fun reduce' (file : file) =
((*Print.prefaces "trySub"
[("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
case t of
- (TFfi ("Basis", "string"), _) => doSub ()
- | (TSignal _, _) => e
+ (TSignal _, _) => e
| _ =>
case e' of
(ECase _, _) => e
diff --git a/src/monoize.sml b/src/monoize.sml
index 4aeddcae..22b4e0e7 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -50,11 +50,13 @@ structure RM = BinaryMapFn(struct
(L'.TRecord r2, E.dummySpan))
end)
+val uses_similar = ref false
+
local
val url_prefixes = ref []
in
-fun reset () = url_prefixes := []
+fun reset () = (url_prefixes := []; uses_similar := false)
fun addPrefix prefix =
let
@@ -355,6 +357,8 @@ fun monoType env =
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
+ | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_bfunc"), _), _), _), _), _), _) =>
+ (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
@@ -2693,6 +2697,40 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
((L'.EFfi ("Basis", "sql_known"), loc), fm)
+ | L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "sql_bfunc"), _),
+ _), _),
+ _), _),
+ _), _),
+ _), _),
+ _), _),
+ _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
+ (L'.EAbs ("x1", s, s,
+ (L'.EAbs ("x2", s, s,
+ strcat [(L'.ERel 2, loc),
+ str "(",
+ (L'.ERel 1, loc),
+ str ",",
+ (L'.ERel 0, loc),
+ str ")"]), loc)), loc)), loc),
+ fm)
+ end
+ | L.EFfi ("Basis", "sql_similarity") =>
+ ((case #supportsSimilar (Settings.currentDbms ()) of
+ NONE => ErrorMsg.errorAt loc "The DBMS you've selected doesn't support SIMILAR."
+ | _ => ());
+ uses_similar := true;
+ (str "similarity", fm))
+
| (L.ECApp (
(L.ECApp (
(L.ECApp (
@@ -4593,7 +4631,8 @@ fun monoize env file =
in
(env, Fm.enter fm, (L'.DDatabase {name = s,
expunge = nExp,
- initialize = nIni}, loc)
+ initialize = nIni,
+ usesSimilar = false}, loc)
:: (dExp, loc)
:: (dIni, loc)
:: ds)
@@ -4617,6 +4656,12 @@ fun monoize env file =
| _ =>
ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
(env, Fm.empty mname, []) file
+ val ds = map (fn (L'.DDatabase r, loc) =>
+ (L'.DDatabase {name = #name r,
+ expunge = #expunge r,
+ initialize = #initialize r,
+ usesSimilar = !uses_similar}, loc)
+ | x => x) ds
val monoFile = (rev ds, [])
in
pvars := RM.empty;
diff --git a/src/mysql.sml b/src/mysql.sml
index ff1c379d..74954c0f 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1612,6 +1612,7 @@ val () = addDbms {name = "mysql",
requiresTimestampDefaults = true,
supportsIsDistinctFrom = true,
supportsSHA512 = SOME {InitializeDb = "",
- GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}}
+ GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"},
+ supportsSimilar = NONE}
end
diff --git a/src/postgres.sml b/src/postgres.sml
index 94f0e42e..3e53ed77 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -1155,8 +1155,9 @@ val () = addDbms {name = "postgres",
windowFunctions = true,
requiresTimestampDefaults = false,
supportsIsDistinctFrom = true,
- supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION pgcrypto;",
- GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}}
+ supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pgcrypto;",
+ GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"},
+ supportsSimilar = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pg_trgm;"}}
val () = setDbms "postgres"
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 06f49fef..aee8e7a9 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -54,6 +54,14 @@ val deKnown = List.filter (fn Known _ => false
| KnownC _ => false
| _ => true)
+fun p_env_item ei =
+ Print.PD.string (case ei of
+ Unknown => "?"
+ | Known _ => "K"
+ | UnknownC => "C?"
+ | KnownC _ => "CK"
+ | Lift _ => "^")
+
datatype result = Yes of env | No | Maybe
fun match (env, p : pat, e : exp) =
@@ -124,7 +132,8 @@ fun match (env, p : pat, e : exp) =
end
fun con env (all as (c, loc)) =
- ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*)
+ ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all),
+ ("env", Print.p_list p_env_item env)];*)
case c of
TFun (c1, c2) => (TFun (con env c1, con env c2), loc)
| TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc)
@@ -139,7 +148,7 @@ fun con env (all as (c, loc)) =
| Unknown :: rest => find (n', rest, nudge, liftC)
| Known _ :: rest => find (n', rest, nudge, liftC)
| Lift (liftC', _) :: rest => find (n', rest, nudge + liftC',
- liftC + liftC')
+ liftC + liftC')
| UnknownC :: rest =>
if n' = 0 then
(CRel (n + nudge), loc)
@@ -228,154 +237,156 @@ fun patCon pc =
kind = kind}
fun exp env (all as (e, loc)) =
- case e of
- EPrim _ => all
- | ERel n =>
- let
- fun find (n', env, nudge, liftC, liftE) =
- case env of
- [] => (ERel (n + nudge), loc)
- | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE')
- | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE)
- | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE)
- | Unknown :: rest =>
- if n' = 0 then
- (ERel (n + nudge), loc)
- else
- find (n' - 1, rest, nudge, liftC, liftE + 1)
- | Known e :: rest =>
- if n' = 0 then
- ((*print "SUBSTITUTING\n";*)
- exp (Lift (liftC, liftE) :: rest) e)
- else
- find (n' - 1, rest, nudge - 1, liftC, liftE)
- in
- find (n, env, 0, 0, 0)
- end
- | ENamed _ => all
- | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc)
- | EFfi _ => all
- | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc)
-
- | EApp (e1, e2) =>
- let
- val e1 = exp env e1
- val e2 = exp env e2
- in
- case #1 e1 of
- EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b
- | _ => (EApp (e1, e2), loc)
- end
-
- | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc)
-
- | ECApp (e, c) =>
- let
- val e = exp env e
- val c = con env c
- in
- case #1 e of
- ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b
- | _ => (ECApp (e, c), loc)
- end
-
- | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc)
-
- | EKApp (e, k) => (EKApp (exp env e, k), loc)
- | EKAbs (x, e) => (EKAbs (x, exp env e), loc)
-
- | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
- | EField (e, c, {field = f, rest = r}) =>
- let
- val e = exp env e
- val c = con env c
-
- fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc)
- in
- case (#1 e, #1 c) of
- (ERecord xcs, CName x) =>
- (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
- NONE => default ()
- | SOME (_, e, _) => e)
- | _ => default ()
- end
-
- | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc)
- | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e,
- con env c,
- {field = con env f, rest = con env r}), loc)
- | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc)
-
- | ECase (e, pes, {disc = d, result = r}) =>
- let
- val others = {disc = con env d, result = con env r}
-
- fun patBinds (p, _) =
- case p of
- PVar _ => 1
- | PPrim _ => 0
- | PCon (_, _, _, NONE) => 0
- | PCon (_, _, _, SOME p) => patBinds p
- | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
-
- fun pat (all as (p, loc)) =
- case p of
- PVar (x, t) => (PVar (x, con env t), loc)
- | PPrim _ => all
- | PCon (dk, pc, cs, po) =>
- (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
- | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
-
- fun push () =
- (ECase (exp env e,
- map (fn (p, e) => (pat p,
- exp (List.tabulate (patBinds p,
- fn _ => Unknown) @ env) e))
- pes, others), loc)
-
- fun search pes =
- case pes of
- [] => push ()
- | (p, body) :: pes =>
- case match (env, p, e) of
- No => search pes
- | Maybe => push ()
- | Yes env' => exp env' body
- in
- search pes
- end
-
- | EWrite e => (EWrite (exp env e), loc)
- | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
-
- | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc)
-
- | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc)
+ ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all)];*)
+ case e of
+ EPrim _ => all
+ | ERel n =>
+ let
+ fun find (n', env, nudge, liftC, liftE) =
+ case env of
+ [] => (ERel (n + nudge), loc)
+ | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE')
+ | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE)
+ | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE)
+ | Unknown :: rest =>
+ if n' = 0 then
+ (ERel (n + nudge), loc)
+ else
+ find (n' - 1, rest, nudge, liftC, liftE + 1)
+ | Known e :: rest =>
+ if n' = 0 then
+ ((*print "SUBSTITUTING\n";*)
+ exp (Lift (liftC, liftE) :: rest) e)
+ else
+ find (n' - 1, rest, nudge - 1, liftC, liftE)
+ in
+ find (n, env, 0, 0, 0)
+ end
+ | ENamed _ => all
+ | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc)
+ | EFfi _ => all
+ | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc)
+
+ | EApp (e1, e2) =>
+ let
+ val e1 = exp env e1
+ val e2 = exp env e2
+ in
+ case #1 e1 of
+ EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b
+ | _ => (EApp (e1, e2), loc)
+ end
+
+ | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc)
+
+ | ECApp (e, c) =>
+ let
+ val e = exp env e
+ val c = con env c
+ in
+ case #1 e of
+ ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b
+ | _ => (ECApp (e, c), loc)
+ end
+
+ | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc)
+
+ | EKApp (e, k) => (EKApp (exp env e, k), loc)
+ | EKAbs (x, e) => (EKAbs (x, exp env e), loc)
+
+ | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
+ | EField (e, c, {field = f, rest = r}) =>
+ let
+ val e = exp env e
+ val c = con env c
+
+ fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc)
+ in
+ case (#1 e, #1 c) of
+ (ERecord xcs, CName x) =>
+ (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
+ NONE => default ()
+ | SOME (_, e, _) => e)
+ | _ => default ()
+ end
+
+ | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc)
+ | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e,
+ con env c,
+ {field = con env f, rest = con env r}), loc)
+ | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc)
+
+ | ECase (e, pes, {disc = d, result = r}) =>
+ let
+ val others = {disc = con env d, result = con env r}
+
+ fun patBinds (p, _) =
+ case p of
+ PVar _ => 1
+ | PPrim _ => 0
+ | PCon (_, _, _, NONE) => 0
+ | PCon (_, _, _, SOME p) => patBinds p
+ | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
+
+ fun pat (all as (p, loc)) =
+ case p of
+ PVar (x, t) => (PVar (x, con env t), loc)
+ | PPrim _ => all
+ | PCon (dk, pc, cs, po) =>
+ (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
+ | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
+
+ fun push () =
+ (ECase (exp env e,
+ map (fn (p, e) => (pat p,
+ exp (List.tabulate (patBinds p,
+ fn _ => Unknown) @ env) e))
+ pes, others), loc)
+
+ fun search pes =
+ case pes of
+ [] => push ()
+ | (p, body) :: pes =>
+ case match (env, p, e) of
+ No => search pes
+ | Maybe => push ()
+ | Yes env' => exp env' body
+ in
+ search pes
+ end
+
+ | EWrite e => (EWrite (exp env e), loc)
+ | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
+
+ | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc)
+
+ | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc))
fun reduce file =
let
fun doDecl (d as (_, loc)) =
- case #1 d of
- DCon _ => d
- | DDatatype _ => d
- | DVal (x, n, t, e, s) =>
- let
- val e = exp [] e
- in
- (DVal (x, n, t, e, s), loc)
- end
- | DValRec vis =>
- (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc)
- | DExport _ => d
- | DTable _ => d
- | DSequence _ => d
- | DView _ => d
- | DDatabase _ => d
- | DCookie _ => d
- | DStyle _ => d
- | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
- | DPolicy e1 => (DPolicy (exp [] e1), loc)
- | DOnError _ => d
+ ((*Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)];*)
+ case #1 d of
+ DCon _ => d
+ | DDatatype _ => d
+ | DVal (x, n, t, e, s) =>
+ let
+ val e = exp [] e
+ in
+ (DVal (x, n, t, e, s), loc)
+ end
+ | DValRec vis =>
+ (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc)
+ | DExport _ => d
+ | DTable _ => d
+ | DSequence _ => d
+ | DView _ => d
+ | DDatabase _ => d
+ | DCookie _ => d
+ | DStyle _ => d
+ | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
+ | DPolicy e1 => (DPolicy (exp [] e1), loc)
+ | DOnError _ => d)
in
map doDecl file
end
diff --git a/src/settings.sig b/src/settings.sig
index a2a56407..6a409cdd 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -224,10 +224,11 @@ signature SETTINGS = sig
requiresTimestampDefaults : bool,
supportsIsDistinctFrom : bool,
supportsSHA512 : {InitializeDb : string,
- GenerateHash : string -> string} option
+ GenerateHash : string -> string} option,
(* If supported, give the SQL code to
* enable the feature in a particular
* database and to compute a hash of a value. *)
+ supportsSimilar : {InitializeDb : string} option
}
val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index a85e8053..c8cb049c 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -653,7 +653,8 @@ type dbms = {
windowFunctions: bool,
requiresTimestampDefaults : bool,
supportsIsDistinctFrom : bool,
- supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option
+ supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option,
+ supportsSimilar : {InitializeDb : string} option
}
val dbmses = ref ([] : dbms list)
@@ -688,7 +689,8 @@ val curDb = ref ({name = "",
windowFunctions = false,
requiresTimestampDefaults = false,
supportsIsDistinctFrom = false,
- supportsSHA512 = NONE} : dbms)
+ supportsSHA512 = NONE,
+ supportsSimilar = NONE} : dbms)
fun addDbms v = dbmses := v :: !dbmses
fun setDbms s =
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 9bb86ecf..0e97bf69 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -857,6 +857,7 @@ val () = addDbms {name = "sqlite",
windowFunctions = false,
requiresTimestampDefaults = false,
supportsIsDistinctFrom = false,
- supportsSHA512 = NONE}
+ supportsSHA512 = NONE,
+ supportsSimilar = NONE}
end
diff --git a/src/urweb.grm b/src/urweb.grm
index afebff0a..dea7bdf5 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -2276,6 +2276,15 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In
val e = (EApp (e, fname), loc)
in
(EApp (e, sqlexp), loc)
+ end)
+ | fname LPAREN sqlexp COMMA sqlexp RPAREN (let
+ val loc = s (fnameleft, RPARENright)
+
+ val e = (EVar (["Basis"], "sql_bfunc", Infer), loc)
+ val e = (EApp (e, fname), loc)
+ val e = (EApp (e, sqlexp1), loc)
+ in
+ (EApp (e, sqlexp2), loc)
end)
| LPAREN query RPAREN (let
val loc = s (LPARENleft, RPARENright)
diff --git a/tests/badkind.ur b/tests/badkind.ur
new file mode 100644
index 00000000..600f7a35
--- /dev/null
+++ b/tests/badkind.ur
@@ -0,0 +1 @@
+fun main () : transaction page = <xml>ahoy!</xml>
diff --git a/tests/badkind.urp b/tests/badkind.urp
new file mode 100644
index 00000000..934e4928
--- /dev/null
+++ b/tests/badkind.urp
@@ -0,0 +1,3 @@
+rewrite Badkind/main /
+
+badkind
diff --git a/tests/filter.urp b/tests/filter.urp
index 102a1871..ddf1a3df 100644
--- a/tests/filter.urp
+++ b/tests/filter.urp
@@ -1,4 +1,5 @@
debug
database dbname=filter
+sql filter.sql
filter
diff --git a/tests/html5_cforms.ur b/tests/html5_cforms.ur
index be07d07e..317a0638 100644
--- a/tests/html5_cforms.ur
+++ b/tests/html5_cforms.ur
@@ -9,8 +9,8 @@ fun main () : transaction page =
d <- source "";
e <- source "";
f <- source "";
- g <- source 1.0;
- h <- source 1.0;
+ g <- source (Some 1.0);
+ h <- source (Some 1.0);
i <- source "#CCCCCC";
j <- source "2014/11/16";
k <- source "2014/11/16 12:30:45";
diff --git a/tests/rpc_unit.ur b/tests/rpc_unit.ur
new file mode 100644
index 00000000..befd6045
--- /dev/null
+++ b/tests/rpc_unit.ur
@@ -0,0 +1,8 @@
+val callme = return ((), (), "A", (), ())
+
+val main : transaction page = return <xml><body>
+ <button value="CLICK ME"
+ onclick={fn _ =>
+ (_, _, s, _, _) <- rpc callme;
+ alert s}/>
+</body></xml>
diff --git a/tests/tooEager.ur b/tests/tooEager.ur
new file mode 100644
index 00000000..c84a6d6c
--- /dev/null
+++ b/tests/tooEager.ur
@@ -0,0 +1,18 @@
+fun test (i: list int) : transaction unit =
+ a <- return (Some "abc");
+ c <- (case a of
+ None => return "1"
+ | Some b =>
+ debug "not happening :(";
+ return "2"
+ );
+ (case i of
+ [] => return ()
+ | first :: _ => debug c)
+
+fun main (): transaction page =
+ return <xml>
+ <body>
+ <button onclick={fn _ => rpc (test [])}>click</button>
+ </body>
+ </xml>
diff --git a/tests/trgm.ur b/tests/trgm.ur
new file mode 100644
index 00000000..45783366
--- /dev/null
+++ b/tests/trgm.ur
@@ -0,0 +1,25 @@
+table turtles : { Nam : string }
+
+fun add name =
+ dml (INSERT INTO turtles(Nam)
+ VALUES ({[name]}))
+
+fun closest name =
+ List.mapQuery (SELECT *
+ FROM turtles
+ ORDER BY similarity(turtles.Nam, {[name]}) DESC
+ LIMIT 5)
+ (fn r => r.Turtles.Nam)
+
+val main =
+ name <- source "";
+ results <- source [];
+ return <xml><body>
+ Name: <ctextbox source={name}/><br/>
+ <button value="Add" onclick={fn _ => n <- get name; rpc (add n)}/><br/>
+ <button value="Search" onclick={fn _ => n <- get name; ls <- rpc (closest n); set results ls}/><br/>
+ <dyn signal={rs <- signal results;
+ return <xml><ol>
+ {List.mapX (fn n => <xml><li>{[n]}</li></xml>) rs}
+ </ol></xml>}/>
+ </body></xml>
diff --git a/tests/trgm.urp b/tests/trgm.urp
new file mode 100644
index 00000000..326151e7
--- /dev/null
+++ b/tests/trgm.urp
@@ -0,0 +1,6 @@
+database dbname=trgm
+sql trgm.sql
+rewrite all Trgm/*
+
+$/list
+trgm
diff --git a/tests/trgm.urs b/tests/trgm.urs
new file mode 100644
index 00000000..61778b87
--- /dev/null
+++ b/tests/trgm.urs
@@ -0,0 +1 @@
+val main : transaction page
diff --git a/tests/wildsig.ur b/tests/wildsig.ur
new file mode 100644
index 00000000..336772a7
--- /dev/null
+++ b/tests/wildsig.ur
@@ -0,0 +1,7 @@
+signature S = sig
+ val x : _
+end
+
+structure M : S = struct
+ val x = 7
+end