summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGELOG12
-rw-r--r--Makefile.am11
-rw-r--r--build.bgb3
-rw-r--r--configure.ac2
-rw-r--r--doc/LICENSE27
-rw-r--r--doc/manual.tex7
-rw-r--r--include/urweb/types_cpp.h2
-rw-r--r--lib/js/urweb.js21
-rw-r--r--lib/ur/basis.urs6
-rw-r--r--lib/ur/list.ur12
-rw-r--r--lib/ur/list.urs3
-rw-r--r--lib/ur/option.ur5
-rw-r--r--lib/ur/option.urs1
-rw-r--r--src/c/http.c32
-rw-r--r--src/c/static.c1
-rw-r--r--src/c/urweb.c9
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml41
-rw-r--r--src/demo.sml7
-rw-r--r--src/elab_env.sig3
-rw-r--r--src/elab_env.sml93
-rw-r--r--src/elab_print.sml6
-rw-r--r--src/elaborate.sml69
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml19
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml10
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/urweb.grm44
-rw-r--r--tests/malformed.ur3
-rw-r--r--tests/malformed.urp5
-rw-r--r--tests/sigInModule.ur8
-rw-r--r--tests/topLevelPattern.ur5
35 files changed, 391 insertions, 93 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 89fee4f2..94d3b0a4 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,16 @@
========
+20170720
+========
+
+- New .urp directive: 'jsModule'
+- New compiler command-line option: '-js'
+- New HTML attribute for <button>: 'disabled'
+- Allow inexhaustive patterns for lefthand sides of top-level 'val' declarations
+- New standard-library functions: 'List.appi' and 'Option.app'
+- Support for Emacs bg-build mode
+- Bug fixes and improvements to error messages
+
+========
20170105
========
diff --git a/Makefile.am b/Makefile.am
index 83a08171..f0392de0 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -19,6 +19,7 @@ SUBDIRS = src/c
smlnj: src/urweb.cm xml/entities.sml
mlton: bin/urweb
+mlton-tc: bin/urwebtc
clean-local:
rm -f bin/urweb src/urweb.mlton.* \
@@ -60,6 +61,12 @@ bin/urweb: src/compiler.mlb xml/entities.sml \
src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml
mkdir -p bin
$(MLTON) $(MLTONARGS) -mlb-path-var 'SRC $(abs_srcdir)/src' -mlb-path-var 'BUILD $(abs_builddir)/src' -output $@ $<
+bin/urwebtc: src/compiler.mlb xml/entities.sml \
+ src/urweb.mlb $(srcdir)/src/*.sig $(srcdir)/src/*.sml src/config.sml \
+ src/urweb.mlton.lex.sml \
+ src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml
+ mkdir -p bin
+ $(MLTON) $(MLTONARGS) -prefer-abs-paths true -show-def-use compiler.du -stop tc -mlb-path-var 'SRC $(abs_srcdir)/src' -mlb-path-var 'BUILD $(abs_builddir)/src' -output $@ $<
xml/entities.sml: xml/parse xml/xhtml-lat1.ent xml/xhtml-special.ent xml/xhtml-symbol.ent
$^ > $@
@@ -116,7 +123,7 @@ test:
bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo
rm -f $(TESTDB)
sqlite3 $(TESTDB) < demo/demo.sql
- demo/demo.exe -a 127.0.0.1 & echo $$! > $(TESTPID)
+ demo/demo.exe -q -a 127.0.0.1 & echo $$! > $(TESTPID)
sleep 1
(curl -s 'http://localhost:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false)
(curl -s 'http://localhost:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false)
@@ -126,7 +133,7 @@ test:
echo "Running IPv6 tests."; \
rm -f $(TESTDB); \
sqlite3 $(TESTDB) < demo/demo.sql; \
- demo/demo.exe -A ::1 & echo $$! > $(TESTPID); \
+ demo/demo.exe -q -A ::1 & echo $$! > $(TESTPID); \
sleep 1; \
(curl -g -6 -s 'http://[::1]:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false); \
(curl -g -6 -s 'http://[::1]:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false); \
diff --git a/build.bgb b/build.bgb
new file mode 100644
index 00000000..3898ee03
--- /dev/null
+++ b/build.bgb
@@ -0,0 +1,3 @@
+(bg-build
+ :name "Compiler"
+ :shell "nice -n5 make bin/urwebtc")
diff --git a/configure.ac b/configure.ac
index c87b37ed..5786c582 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-AC_INIT([urweb], [20170105])
+AC_INIT([urweb], [20170720])
WORKING_VERSION=0
AC_USE_SYSTEM_EXTENSIONS
diff --git a/doc/LICENSE b/doc/LICENSE
new file mode 100644
index 00000000..af0d8487
--- /dev/null
+++ b/doc/LICENSE
@@ -0,0 +1,27 @@
+The code in the tutorials files (intro.ur and tlc.ur), excluding comments, is additionally released under the following license (same as for Ur/Web itself):
+
+Copyright (c) 2008-2011, Adam Chlipala
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+- Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+- The names of contributors may not be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+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
+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
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/doc/manual.tex b/doc/manual.tex
index b65809d0..eaf7aab5 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -155,6 +155,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func
\item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules.
\item \texttt{jsFile FILENAME} asks to serve the contents of a file as JavaScript. All such content is concatenated into a single file, included via a \texttt{<script>} tag on every page that needs client-side scripting.
\item \texttt{jsFunc Module.ident=name} gives the JavaScript name of an FFI value.
+\item \texttt{jsModule Module} helps make \texttt{jsFunc} directives less verbose, by setting a module name to prefix in front of \texttt{name} arguments (so running e.g. \texttt{jsFunc MyFfi.foo=bar} actually sets up \texttt{Mod.bar} as the JavaScript name for that function, if \texttt{jsModule Mod} was run beforehand).
\item \texttt{library FILENAME} parses \texttt{FILENAME.urp} and merges its contents with the rest of the current file's contents. If \texttt{FILENAME.urp} doesn't exist, the compiler also tries \texttt{FILENAME/lib.urp}.
\item \texttt{limit class num} sets a resource usage limit for generated applications. The limit \texttt{class} will be set to the non-negative integer \texttt{num}. The classes are:
\begin{itemize}
@@ -275,6 +276,8 @@ sqlite3 path/to/database/file <app.sql
\item \texttt{-explainEmbed}: Trigger more verbose error messages about inability to embed server-side values in client-side code.
+\item \texttt{-js FILENAME}: Ur/Web applications with client-side code link in generated JavaScript files, which, by default, are assigned random-looking names. Use this directive to override the filename chosen for the JavaScript code. Be forewarned that the default method uses a name based on hashing the code itself, which is done for a good reason: browsers are very eager to cache JavaScript code, and application changes may fail to propagate quickly to browsers if this filename stays the same between versions. In such cases, it isn't just that the user sees an old version of your application. Instead, the application runs with a mix of old and new files, leading to arbitrary bugs that Ur/Web prevents, when used properly.
+
\item \texttt{-limit class num}: Equivalent to the \texttt{limit} directive from \texttt{.urp} files
\item \texttt{-moduleOf FILENAME}: Prints the Ur/Web module name corresponding to source file \texttt{FILENAME}, exiting immediately afterward.
@@ -552,7 +555,7 @@ $$\begin{array}{rrcll}
&&& \_ & \textrm{wildcard} \\
&&& (e) & \textrm{explicit precedence} \\
\\
- \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\
+ \textrm{Local declarations} & ed &::=& \cd{val} \; p = e & \textrm{non-recursive value} \\
&&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually recursive values} \\
\end{array}$$
@@ -563,7 +566,7 @@ $$\begin{array}{rrcll}
\textrm{Declarations} & d &::=& \mt{con} \; x :: \kappa = c & \textrm{constructor synonym} \\
&&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\
&&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\
- &&& \mt{val} \; x : \tau = e & \textrm{value} \\
+ &&& \mt{val} \; p = e & \textrm{value} \\
&&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually recursive values} \\
&&& \mt{structure} \; X : S = M & \textrm{module definition} \\
&&& \mt{signature} \; X = S & \textrm{signature definition} \\
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 47086791..2fa473ac 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -113,7 +113,7 @@ typedef struct {
uw_logger log_error, log_debug;
} uw_loggers;
-#define ERROR_BUF_LEN 1024
+#define ERROR_BUF_LEN 10240
typedef struct {
size_t max;
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 222a8322..ebe192ca 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1127,6 +1127,23 @@ function inpt(type, s, name) {
return x;
}
+function inpt_float(type, s, name) {
+ if (suspendScripts)
+ return;
+
+ var filterFloat = function(value) {
+ if (/^(\-|\+)?([0-9]+(\.[0-9]+)?|Infinity)$/
+ .test(value))
+ return Number(value);
+ return null;
+ }
+ var x = input(document.createElement("input"), s, function(x) { return function(v) { if (x.value != v) x.value = v; }; }, type, name);
+ x.value = s.data;
+ x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, filterFloat(x.value)) };
+
+ return x;
+}
+
function inp(s, name) {
return inpt("text", s, name);
@@ -1157,11 +1174,11 @@ function color(s, name) {
}
function number(s, name) {
- return inpt("number", s, name);
+ return inpt_float("number", s, name);
}
function range(s, name) {
- return inpt("range", s, name);
+ return inpt_float("range", s, name);
}
function date(s, name) {
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 23896e27..89a48d59 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -1076,8 +1076,8 @@ val curl : ctext
val ctel : ctext
val ccolor : ctext
-val cnumber : cformTag ([Source = source float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val crange : cformTag ([Source = source float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
@@ -1085,7 +1085,7 @@ val cmonth : cformTag ([Source = source string, Min = string, Max = string, Size
val cweek : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val ctime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val button : cformTag ([Value = string] ++ boxAttrs) []
+val button : cformTag ([Value = string, Disabled = bool] ++ boxAttrs) []
val ccheckbox : cformTag ([Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 50764e46..cc533676 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -311,6 +311,18 @@ fun app [m] (_ : monad m) [a] f =
app'
end
+fun appi [m] (_ : monad m) [a] f =
+ let
+ fun app' i ls =
+ case ls of
+ [] => return ()
+ | x :: ls =>
+ f i x;
+ app' (i + 1) ls
+ in
+ app' 0
+ end
+
fun mapQuery [tables ::: {{Type}}] [exps ::: {Type}] [t ::: Type]
[tables ~ exps] (q : sql_query [] [] tables exps)
(f : $(exps ++ map (fn fields :: {Type} => $fields) tables) -> t) =
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 432d8c1a..fd56679d 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -65,6 +65,9 @@ val all : a ::: Type -> (a -> bool) -> t a -> bool
val app : m ::: (Type -> Type) -> monad m -> a ::: Type
-> (a -> m unit) -> t a -> m unit
+val appi : m ::: (Type -> Type) -> monad m -> a ::: Type
+ -> (int -> a -> m unit) -> t a -> m unit
+
val tabulateM : m ::: (Type -> Type) -> monad m -> a ::: Type
-> (int -> m a) -> int -> m (t a)
diff --git a/lib/ur/option.ur b/lib/ur/option.ur
index 05c50d1f..baa08466 100644
--- a/lib/ur/option.ur
+++ b/lib/ur/option.ur
@@ -40,6 +40,11 @@ fun mp [a] [b] f x =
None => None
| Some y => Some (f y)
+fun app [m] [a] (_ : monad m) (f : a -> m {}) x =
+ case x of
+ None => return ()
+ | Some y => f y
+
fun bind [a] [b] f x =
case x of
None => None
diff --git a/lib/ur/option.urs b/lib/ur/option.urs
index 126999a3..c30c40e7 100644
--- a/lib/ur/option.urs
+++ b/lib/ur/option.urs
@@ -9,6 +9,7 @@ val isNone : a ::: Type -> t a -> bool
val isSome : a ::: Type -> t a -> bool
val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b
+val app : m ::: (Type -> Type) -> a ::: Type -> monad m -> (a -> m {}) -> t a -> m {}
val bind : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b
val get : a ::: Type -> a -> option a -> a
diff --git a/src/c/http.c b/src/c/http.c
index 1bc58677..21ad809f 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -75,6 +75,8 @@ static void log_debug(void *data, const char *fmt, ...) {
static uw_loggers ls = {NULL, log_error, log_debug};
+static unsigned max_buf_size = 1024 * 1024; // That's 1MB.
+
static void *worker(void *data) {
int me = *(int *)data;
uw_context ctx = uw_request_new_context(me, &uw_application, &ls);
@@ -100,6 +102,12 @@ static void *worker(void *data) {
if (back - buf == buf_size - 1) {
char *new_buf;
size_t new_buf_size = buf_size*2;
+ if (new_buf_size > max_buf_size) {
+ qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size);
+ close(sock);
+ sock = 0;
+ break;
+ }
new_buf = realloc(buf, new_buf_size);
if(!new_buf) {
qfprintf(stderr, "Realloc failed while receiving header\n");
@@ -156,6 +164,12 @@ static void *worker(void *data) {
if (back - buf == buf_size - 1) {
char *new_buf;
size_t new_buf_size = buf_size * 2;
+ if (new_buf_size > max_buf_size) {
+ qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size);
+ close(sock);
+ sock = 0;
+ break;
+ }
new_buf = realloc(buf, new_buf_size);
if(!new_buf) {
qfprintf(stderr, "Realloc failed while receiving content\n");
@@ -314,7 +328,7 @@ static void *worker(void *data) {
}
static void help(char *cmd) {
- printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\n", cmd);
+ printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-m <bytes>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\nThe '-m' sets the maximum size (in bytes) for any buffer used to hold HTTP data sent by clients. (The default is 1 MB.)\n", cmd);
}
static void sigint(int signum) {
@@ -345,7 +359,7 @@ int main(int argc, char *argv[]) {
my_addr.sa.sa_family = AF_INET;
my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
- while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) {
+ while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:m:")) != -1) {
switch (opt) {
case '?':
fprintf(stderr, "Unknown command-line option\n");
@@ -409,6 +423,16 @@ int main(int argc, char *argv[]) {
quiet = 1;
break;
+ case 'm':
+ opt = atoi(optarg);
+ if (opt <= 0) {
+ fprintf(stderr, "Invalid maximum buffer size\n");
+ help(argv[0]);
+ return 1;
+ }
+ max_buf_size = opt;
+ break;
+
default:
fprintf(stderr, "Unexpected getopt() behavior\n");
return 1;
@@ -456,6 +480,10 @@ int main(int argc, char *argv[]) {
sin_size = sizeof their_addr;
+ qprintf("Starting the Ur/Web native HTTP server, which is intended for use\n"
+ "ONLY DURING DEVELOPMENT. You probably want to use one of the other backends,\n"
+ "behind a production-quality HTTP server, for a real deployment.\n\n");
+
qprintf("Listening on port %d....\n", uw_port);
{
diff --git a/src/c/static.c b/src/c/static.c
index 7f63d393..d70881e2 100644
--- a/src/c/static.c
+++ b/src/c/static.c
@@ -38,6 +38,7 @@ int main(int argc, char *argv[]) {
fk = uw_begin(ctx, argv[1]);
if (fk == SUCCESS || fk == RETURN_INDIRECTLY) {
+ uw_commit(ctx);
uw_print(ctx, 1);
puts("");
return 0;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index afe8457b..6f2dde38 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -180,8 +180,11 @@ static uw_Basis_int my_rand() {
return -1;
}
-static client *new_client() {
+static client *new_client(uw_context ctx) {
client *c;
+ int pass = my_rand();
+
+ if (pass < 0) uw_error(ctx, FATAL, "Random number generation failed during client initialization");
pthread_mutex_lock(&clients_mutex);
@@ -205,7 +208,7 @@ static client *new_client() {
pthread_mutex_lock(&c->lock);
c->mode = USED;
- c->pass = my_rand();
+ c->pass = pass;
c->sock = -1;
c->last_contact = time(NULL);
uw_buffer_reset(&c->msgs);
@@ -817,7 +820,7 @@ void uw_login(uw_context ctx) {
uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass);
}
} else if (ctx->needs_push) {
- client *c = new_client();
+ client *c = new_client(ctx);
if (c == NULL)
uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients");
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 688b3e4d..53587ff7 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2513,8 +2513,12 @@ fun p_decl env (dAll as (d, loc) : decl) =
| DJavaScript s =>
let
+ val name =
+ (case Settings.getOutputJsFile () of
+ NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"
+ | SOME s => s)
val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
- file = "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"}
+ file = name}
in
box [string "static char jslib[] = \"",
string (Prim.toCString s),
diff --git a/src/compiler.sig b/src/compiler.sig
index a4b3e562..952c7070 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -48,6 +48,7 @@ signature COMPILER = sig
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
+ jsModule : string option,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
diff --git a/src/compiler.sml b/src/compiler.sml
index 481f04b6..c13de304 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -52,6 +52,7 @@ type job = {
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
+ jsModule : string option,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
@@ -273,7 +274,7 @@ val parseUr = {
fun p_job ({prefix, database, exe, sql, sources, debug, profile,
timeout, ffi, link, headers, scripts,
- clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
+ clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) =
let
open Print.PD
open Print
@@ -312,6 +313,9 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile,
p_ffi "BenignEffectful" benignEffectful,
p_ffi "ClientOnly" clientOnly,
p_ffi "ServerOnly" serverOnly,
+ case jsModule of
+ NONE => string "No JavaScript FFI module"
+ | SOME m => string ("JavaScript FFI module: " ^ m),
p_list_sep (box []) (fn ((m, s), s') =>
box [string "JsFunc", space, string m, string ".", string s,
space, string "=", space, string s', newline]) jsFuncs,
@@ -368,6 +372,7 @@ fun institutionalizeJob (job : job) =
Settings.setBenignEffectful (#benignEffectful job);
Settings.setClientOnly (#clientOnly job);
Settings.setServerOnly (#serverOnly job);
+ Settings.setJsModule (#jsModule job);
Settings.setJsFuncs (#jsFuncs job);
Settings.setRewriteRules (#rewrites job);
Settings.setUrlRules (#filterUrl job);
@@ -445,6 +450,7 @@ fun parseUrp' accLibs fname =
benignEffectful = [],
clientOnly = [],
serverOnly = [],
+ jsModule = NONE,
jsFuncs = [],
rewrites = [{pkind = Settings.Any,
kind = Settings.Prefix,
@@ -543,9 +549,16 @@ fun parseUrp' accLibs fname =
acc
else
let
- val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
- (String.explode line))
- val fname = relifyA fname
+ fun trim s =
+ let
+ val s = Substring.full s
+ val (_, s) = Substring.splitl Char.isSpace s
+ val (s, _) = Substring.splitr Char.isSpace s
+ in
+ Substring.string s
+ end
+
+ val fname = relifyA (trim line)
in
fname :: acc
end
@@ -572,6 +585,7 @@ fun parseUrp' accLibs fname =
val benignEffectful = ref []
val clientOnly = ref []
val serverOnly = ref []
+ val jsModule = ref NONE
val jsFuncs = ref []
val rewrites = ref []
val url = ref []
@@ -609,6 +623,7 @@ fun parseUrp' accLibs fname =
benignEffectful = rev (!benignEffectful),
clientOnly = rev (!clientOnly),
serverOnly = rev (!serverOnly),
+ jsModule = !jsModule,
jsFuncs = rev (!jsFuncs),
rewrites = rev (!rewrites),
filterUrl = rev (!url),
@@ -667,6 +682,7 @@ fun parseUrp' accLibs fname =
benignEffectful = #benignEffectful old @ #benignEffectful new,
clientOnly = #clientOnly old @ #clientOnly new,
serverOnly = #serverOnly old @ #serverOnly new,
+ jsModule = #jsModule old,
jsFuncs = #jsFuncs old @ #jsFuncs new,
rewrites = #rewrites old @ #rewrites new,
filterUrl = #filterUrl old @ #filterUrl new,
@@ -802,6 +818,10 @@ fun parseUrp' accLibs fname =
| "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
| "clientOnly" => clientOnly := ffiS () :: !clientOnly
| "serverOnly" => serverOnly := ffiS () :: !serverOnly
+ | "jsModule" =>
+ (case !jsModule of
+ NONE => jsModule := SOME arg
+ | SOME _ => ())
| "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
| "rewrite" =>
let
@@ -1005,6 +1025,8 @@ val parse = {
val defed = ref SS.empty
val fulls = ref SS.empty
+ val caughtOneThatIsn'tAFile = ref false
+
fun parseOne fname =
let
val mname = nameOf fname
@@ -1129,7 +1151,16 @@ val parse = {
in
checkErrors ();
d
- end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
+ end handle MissingFile fname => (if not (!caughtOneThatIsn'tAFile)
+ andalso CharVector.exists Char.isSpace fname then
+ (caughtOneThatIsn'tAFile := true;
+ ErrorMsg.error ("In .urp files, all configuration directives must come before any blank lines.\n"
+ ^ "However, this .urp file contains at least one suspicious line in a position\n"
+ ^ "where filenames belong (after the first blank line) but containing a space\n"
+ ^ "character."))
+ else
+ ();
+ ErrorMsg.error ("Missing source file: " ^ fname);
(Source.DSequence "", ErrorMsg.dummySpan))
val dsFfi = map parseFfi ffi
diff --git a/src/demo.sml b/src/demo.sml
index 47d22395..62b9037a 100644
--- a/src/demo.sml
+++ b/src/demo.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
@@ -111,6 +111,7 @@ fun make' {prefix, dirname, guided} =
benignEffectful = [],
clientOnly = [],
serverOnly = [],
+ jsModule = NONE,
jsFuncs = [],
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
@@ -280,7 +281,7 @@ fun make' {prefix, dirname, guided} =
val (urpData, out) = startUrp urp
in
finished ();
-
+
SOME (readUrp (urpData,
out))
end
@@ -399,7 +400,7 @@ fun make' {prefix, dirname, guided} =
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
- TextIO.output (outf, "\n")))
+ TextIO.output (outf, "\n")))
in
Option.app (fn db => (TextIO.output (outf, "database ");
TextIO.output (outf, db);
diff --git a/src/elab_env.sig b/src/elab_env.sig
index cbc85cdd..47b31c08 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -96,6 +96,7 @@ signature ELAB_ENV = sig
val pushStrNamed : env -> string -> Elab.sgn -> env * int
val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env
+ val pushStrNamedAs' : bool (* also enrich typeclass instances? *) -> env -> string -> int -> Elab.sgn -> env
val lookupStrNamed : env -> int -> string * Elab.sgn
val lookupStr : env -> string -> (int * Elab.sgn) option
@@ -123,6 +124,4 @@ signature ELAB_ENV = sig
val patBinds : env -> Elab.pat -> env
val patBindsN : Elab.pat -> int
- exception Bad of Elab.con * Elab.con
-
end
diff --git a/src/elab_env.sml b/src/elab_env.sml
index cb08f348..8402bcba 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1097,14 +1097,21 @@ fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
end)
| _ => sgn
-fun sgnSubSgn x =
+fun projectStr env {sgn, str, field} =
+ case #1 (hnormSgn env sgn) of
+ SgnConst sgis =>
+ (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
+ NONE => NONE
+ | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
+ | SgnError => SOME (SgnError, ErrorMsg.dummySpan)
+ | _ => NONE
+
+and sgnSubSgn x =
ElabUtil.Sgn.map {kind = id,
con = sgnS_con x,
sgn_item = id,
sgn = sgnS_sgn x}
-
-
and projectSgn env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
@@ -1123,12 +1130,23 @@ and hnormSgn env (all as (sgn, loc)) =
| SgnProj (m, ms, x) =>
let
val (_, sgn) = lookupStrNamed env m
+
+ fun doProjection (m1, NONE) = NONE
+ | doProjection (m1, SOME (str, sgn)) =
+ case projectStr env {str = str,
+ sgn = sgn,
+ field = m1} of
+ NONE => NONE
+ | SOME sgn' => SOME ((StrProj (str, m1), loc), sgn')
in
- case projectSgn env {str = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms,
- sgn = sgn,
- field = x} of
- NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed"
- | SOME sgn => hnormSgn env sgn
+ case foldl doProjection (SOME ((StrVar m, loc), sgn)) ms of
+ NONE => raise Fail "ElabEnv.hnormSgn: pre-projectSgn failed"
+ | SOME (str, sgn) =>
+ case projectSgn env {str = str,
+ sgn = sgn,
+ field = x} of
+ NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed"
+ | SOME sgn => hnormSgn env sgn
end
| SgnWhere (sgn, ms, x, c) =>
let
@@ -1281,28 +1299,40 @@ fun enrichClasses env classes (m1, ms) sgn =
end
| _ => classes
-fun pushStrNamedAs (env : env) x n sgn =
- {renameK = #renameK env,
- relK = #relK env,
+and pushStrNamedAs' enrich (env : env) x n sgn =
+ let
+ val renameStr = SM.insert (#renameStr env, x, (n, sgn))
+ val str = IM.insert (#str env, n, (x, sgn))
+ fun newEnv classes =
+ {renameK = #renameK env,
+ relK = #relK env,
- renameC = #renameC env,
- relC = #relC env,
- namedC = #namedC env,
+ renameC = #renameC env,
+ relC = #relC env,
+ namedC = #namedC env,
- datatypes = #datatypes env,
- constructors = #constructors env,
+ datatypes = #datatypes env,
+ constructors = #constructors env,
- classes = enrichClasses env (#classes env) (n, []) sgn,
+ classes = classes,
- renameE = #renameE env,
- relE = #relE env,
- namedE = #namedE env,
+ renameE = #renameE env,
+ relE = #relE env,
+ namedE = #namedE env,
- renameSgn = #renameSgn env,
- sgn = #sgn env,
+ renameSgn = #renameSgn env,
+ sgn = #sgn env,
+
+ renameStr = renameStr,
+ str = str}
+ in
+ if enrich then
+ newEnv (enrichClasses (newEnv (#classes env)) (#classes env) (n, []) sgn)
+ else
+ newEnv (#classes env)
+ end
- renameStr = SM.insert (#renameStr env, x, (n, sgn)),
- str = IM.insert (#str env, n, (x, sgn))}
+and pushStrNamedAs env = pushStrNamedAs' true env
fun pushStrNamed env x sgn =
let
@@ -1364,7 +1394,7 @@ fun sgiBinds env (sgi, loc) =
env xncs
end
| SgiVal (x, n, t) => pushENamedAs env x n t
- | SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn
+ | SgiStr (_, x, n, sgn) => pushStrNamedAs' false env x n sgn
| SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
| SgiConstraint _ => env
@@ -1375,15 +1405,6 @@ fun sgnSubCon x =
ElabUtil.Con.map {kind = id,
con = sgnS_con x}
-fun projectStr env {sgn, str, field} =
- case #1 (hnormSgn env sgn) of
- SgnConst sgis =>
- (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
- NONE => NONE
- | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
- | SgnError => SOME (SgnError, ErrorMsg.dummySpan)
- | _ => NONE
-
fun chaseMpath env (n, ms) =
let
val (_, sgn) = lookupStrNamed env n
@@ -1642,8 +1663,8 @@ fun declBinds env (d, loc) =
| DVal (x, n, t, _) => pushENamedAs env x n t
| DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis
| DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
- | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn
- | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
+ | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn
+ | DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn
| DConstraint _ => env
| DExport _ => env
| DTable (tn, x, n, c, _, pc, _, cc) =>
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 06ea097f..8a6a651a 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -678,7 +678,7 @@ and p_sgn env (sgn, _) =
space,
string ":",
space,
- p_sgn (E.pushStrNamedAs env x n sgn) sgn']
+ p_sgn (E.pushStrNamedAs' false env x n sgn) sgn']
| SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
space,
string "where",
@@ -695,7 +695,7 @@ and p_sgn env (sgn, _) =
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
- val m1s = if !debug then
+ val m1x = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
@@ -867,7 +867,7 @@ and p_str env (str, _) =
string s]
| StrFun (x, n, sgn, sgn', str) =>
let
- val env' = E.pushStrNamedAs env x n sgn
+ val env' = E.pushStrNamedAs' false env x n sgn
in
box [string "functor",
space,
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 6965adfd..4a04d4bf 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2489,6 +2489,15 @@ fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan)
fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan)
+fun patVarsOf (p : L.pat) =
+ case #1 p of
+ L.PVar x => [x]
+ | L.PPrim _ => []
+ | L.PCon (_, _, NONE) => []
+ | L.PCon (_, _, SOME p) => patVarsOf p
+ | L.PRecord (xps, _) => ListUtil.mapConcat (fn (_, p) => patVarsOf p) xps
+ | L.PAnnot (p', _) => patVarsOf p'
+
fun dopenConstraints (loc, env, denv) {str, strs} =
case E.lookupStr env str of
NONE => (strError env (UnboundStr (loc, str));
@@ -3807,7 +3816,8 @@ and wildifyStr env (str, sgn) =
foldl (fn ((d, _), nd) =>
case d of
L.DCon (x, _, _) => ndelCon (nd, x)
- | L.DVal (x, _, _) => ndelVal (nd, x)
+ | L.DVal (p, _) =>
+ foldl (fn (x, nd) => ndelVal (nd, x)) nd (patVarsOf p)
| L.DOpen _ => nempty
| L.DStr (x, _, _, (L.StrConst ds', _), _) =>
(case SM.find (nmods nd, x) of
@@ -3855,7 +3865,7 @@ and wildifyStr env (str, sgn) =
| xs =>
let
val ewild = (L.EWild, #2 str)
- val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs
+ val ds'' = map (fn x => (L.DVal ((L.PVar x, #2 str), ewild), #2 str)) xs
in
ds'' @ ds'
end
@@ -4022,22 +4032,55 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([], (env, denv, [])))
end)
- | L.DVal (x, co, e) =>
+ | L.DVal (p, e) =>
let
- val (c', _, gs1) = case co of
- NONE => (cunif env (loc, ktype), ktype, [])
- | SOME c => elabCon (env, denv) c
+ val ((p', pt), (env', bound)) = elabPat (p, (env, SS.empty))
- val (e', et, gs2) = elabExp (env, denv) e
+ val (e', et, gs1) = elabExp (env, denv) e
- val () = checkCon env e' et c'
+ val c' = normClassConstraint env et
- val c' = normClassConstraint env c'
- val (env', n) = E.pushENamed env x c'
+ fun singleVar (p : L.pat) =
+ case #1 p of
+ L.PVar x => SOME x
+ | L.PAnnot (p', _) => singleVar p'
+ | _ => NONE
in
- (*prefaces "DVal" [("x", Print.PD.string x),
- ("c'", p_con env c')];*)
- ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs))
+ unifyCons env loc et pt;
+
+ (case exhaustive (env, et, [p'], loc) of
+ NONE => ()
+ | SOME p => if !mayDelay then
+ delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives
+ else
+ expError env (Inexhaustive (loc, p)));
+
+ case singleVar p of
+ SOME x =>
+ let
+ val (env', n) = E.pushENamed env x et
+ in
+ ([(L'.DVal (x, n, c', e'), loc)], (env', denv, gs1 @ gs))
+ end
+ | NONE =>
+ let
+ val (env', n) = E.pushENamed env "$tmp" et
+ val vars = SS.listItems bound
+ val (decls, env') =
+ ListUtil.foldlMap (fn (x, env') =>
+ let
+ val e = (L.ECase ((L.EVar ([], "$tmp", L.Infer), loc),
+ [(p, (L.EVar ([], x, L.Infer), loc))]), loc)
+ val (e', t, _) = elabExp (env', denv) e
+ val (env', n) = E.pushENamed env' x t
+ in
+ ((L'.DVal (x, n, t, e'), loc),
+ env')
+ end) env' vars
+ in
+ ((L'.DVal ("$tmp", n, c', e'), loc) :: decls,
+ (env', denv, gs1 @ gs))
+ end
end
| L.DValRec vis =>
let
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index fb1a1723..2caa43f8 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -134,6 +134,9 @@ fun oneRun args =
| "-output" :: s :: rest =>
(Settings.setExe (SOME s);
doArgs rest)
+ | "-js" :: s :: rest =>
+ (Settings.setOutputJsFile (SOME s);
+ doArgs rest)
| "-sql" :: s :: rest =>
(Settings.setSql (SOME s);
doArgs rest)
diff --git a/src/settings.sig b/src/settings.sig
index 05ab5e23..256a12b5 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -96,6 +96,7 @@ signature SETTINGS = sig
val isServerOnly : ffi -> bool
(* Which FFI functions may be run in JavaScript? (JavaScript function names included) *)
+ val setJsModule : string option -> unit
val setJsFuncs : (ffi * string) list -> unit
val addJsFunc : ffi * string -> unit
val jsFunc : ffi -> string option
@@ -303,4 +304,6 @@ signature SETTINGS = sig
val addJsFile : string (* filename *) -> unit
val listJsFiles : unit -> {Filename : string, Content : string} list
+ val setOutputJsFile : string option (* filename *) -> unit
+ val getOutputJsFile : unit -> string option
end
diff --git a/src/settings.sml b/src/settings.sml
index 70ea1861..a3263c06 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -346,7 +346,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("asin", "asin"),
("acos", "acos"),
("atan", "atan"),
- ("atan2", "atan2"),
+ ("atan2", "atan2"),
("abs", "abs"),
("now", "now"),
@@ -395,9 +395,15 @@ val jsFuncsBase = basisM [("alert", "alert"),
("htmlifySpecialChar", "htmlifySpecialChar"),
("chr", "chr")]
val jsFuncs = ref jsFuncsBase
-fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
+val jsModule = ref (NONE : string option)
+fun setJsModule m = jsModule := m
+fun jsFuncName f =
+ case !jsModule of
+ SOME m => m ^ "." ^ f
+ | NONE => f
+fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls
fun jsFunc x = M.find (!jsFuncs, x)
-fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
+fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v)
fun allJsFuncs () = M.listItemsi (!jsFuncs)
datatype pattern_kind = Exact | Prefix
@@ -951,6 +957,10 @@ fun addJsFile LoadFromFilename =
fun listJsFiles () = SM.listItems (!jsFiles)
+val jsOutput = ref (NONE : string option)
+fun setOutputJsFile so = jsOutput := so
+fun getOutputJsFile () = !jsOutput
+
fun reset () =
(Globals.setResetTime ();
urlPrefixFull := "/";
@@ -996,6 +1006,7 @@ fun reset () =
mimeTypes := NONE;
files := SM.empty;
jsFiles := SM.empty;
- filePath := ".")
+ filePath := ".";
+ jsOutput := NONE)
end
diff --git a/src/source.sml b/src/source.sml
index 9971ca93..2d8c1ed3 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -157,7 +157,7 @@ datatype decl' =
DCon of string * kind option * con
| DDatatype of (string * string list * (string * con option) list) list
| DDatatypeImp of string * string list * string
- | DVal of string * con option * exp
+ | DVal of pat * exp
| DValRec of (string * con option * exp) list
| DSgn of string * sgn
| DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *)
diff --git a/src/source_print.sml b/src/source_print.sml
index 7b657422..e18a82f9 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -560,9 +560,13 @@ fun p_decl ((d, _) : decl) =
string "datatype",
space,
p_list_sep (string ".") string (ms @ [x'])]
- | DVal vi => box [string "val",
- space,
- p_vali vi]
+ | DVal (p, e) => box [string "val",
+ space,
+ p_pat p,
+ space,
+ string "=",
+ space,
+ p_exp e]
| DValRec vis => box [string "val",
space,
string "rec",
diff --git a/src/sqlite.sml b/src/sqlite.sml
index c7694cde..a9b6389d 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -850,6 +850,6 @@ val () = addDbms {name = "sqlite",
onlyUnion = false,
nestedRelops = false,
windowFunctions = false,
- supportsIsDistinctFrom = true}
+ supportsIsDistinctFrom = false}
end
diff --git a/src/urweb.grm b/src/urweb.grm
index db5473a6..afebff0a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -490,7 +490,7 @@ fun patternOut (e : exp) =
| earga of exp * con -> exp * con
| eargs of exp * con -> exp * con
| eargl of exp * con -> exp * con
- | eargl2 of exp * con -> exp * con
+ | eargl2 of bool * (exp * con -> exp * con)
| branch of pat * exp
| branchs of (pat * exp) list
@@ -622,7 +622,41 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
(case dargs of
[] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
| _ => raise Fail "Arguments specified for imported datatype")
- | VAL vali ([(DVal vali, s (VALleft, valiright))])
+ | VAL pat eargl2 copt EQ eexp (let
+ fun justVar (p : pat) =
+ case #1 p of
+ PVar x => SOME x
+ | PAnnot (p', _) => justVar p'
+ | _ => NONE
+
+ val loc = s (VALleft, eexpright)
+ in
+ case justVar pat of
+ SOME x =>
+ let
+ val t = Option.getOpt (copt, (CWild (KType, loc), loc))
+ val (e, t) = #2 eargl2 (eexp, t)
+ val pat =
+ case #1 t of
+ CWild _ => pat
+ | _ => (PAnnot (pat, t), loc)
+ in
+ [(DVal (pat, e), loc)]
+ end
+ | NONE =>
+ let
+ val pat =
+ case copt of
+ SOME t => (PAnnot (pat, t), loc)
+ | _ => pat
+ in
+ (if #1 eargl2 then
+ ErrorMsg.errorAt loc "Additional arguments not allowed after pattern"
+ else
+ ());
+ [(DVal (pat, eexp), loc)]
+ end
+ end)
| VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
| FUN valis ([(DValRec valis, s (FUNleft, valisright))])
@@ -695,7 +729,7 @@ vali : SYMBOL eargl2 copt EQ eexp (let
val loc = s (SYMBOLleft, eexpright)
val t = Option.getOpt (copt, (CWild (KType, loc), loc))
- val (e, t) = eargl2 (eexp, t)
+ val (e, t) = #2 eargl2 (eexp, t)
in
(SYMBOL, SOME t, e)
end)
@@ -1279,8 +1313,8 @@ eargs : earg (earg)
eargl : eargp eargp (eargp1 o eargp2)
| eargp eargl (eargp o eargl)
-eargl2 : (fn x => x)
- | eargp eargl2 (eargp o eargl2)
+eargl2 : (false, fn x => x)
+ | eargp eargl2 (true, eargp o #2 eargl2)
earg : patS (fn (e, t) =>
let
diff --git a/tests/malformed.ur b/tests/malformed.ur
new file mode 100644
index 00000000..60e0b9f2
--- /dev/null
+++ b/tests/malformed.ur
@@ -0,0 +1,3 @@
+fun main () : transaction page = return <xml><body>
+ FYI, this file isn't the malformed one. That's <tt>malformed.urp</tt>.
+</body></xml>
diff --git a/tests/malformed.urp b/tests/malformed.urp
new file mode 100644
index 00000000..d065a037
--- /dev/null
+++ b/tests/malformed.urp
@@ -0,0 +1,5 @@
+rewrite url Malformed/*
+
+rewrite style Malformed/*
+
+malformed
diff --git a/tests/sigInModule.ur b/tests/sigInModule.ur
new file mode 100644
index 00000000..efb7b0fc
--- /dev/null
+++ b/tests/sigInModule.ur
@@ -0,0 +1,8 @@
+structure A = struct
+ signature S = sig
+ val x : int
+ end
+end
+structure B : A.S = struct
+ val x = 42
+end
diff --git a/tests/topLevelPattern.ur b/tests/topLevelPattern.ur
new file mode 100644
index 00000000..e272c30c
--- /dev/null
+++ b/tests/topLevelPattern.ur
@@ -0,0 +1,5 @@
+val (x, y) = (1, 2)
+
+fun main () : transaction page = return <xml>
+ {[x]} + {[y]} = {[x + y]}
+</xml>