diff options
| -rw-r--r-- | CHANGELOG | 12 | ||||
| -rw-r--r-- | Makefile.am | 11 | ||||
| -rw-r--r-- | build.bgb | 3 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | doc/LICENSE | 27 | ||||
| -rw-r--r-- | doc/manual.tex | 7 | ||||
| -rw-r--r-- | include/urweb/types_cpp.h | 2 | ||||
| -rw-r--r-- | lib/js/urweb.js | 21 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 6 | ||||
| -rw-r--r-- | lib/ur/list.ur | 12 | ||||
| -rw-r--r-- | lib/ur/list.urs | 3 | ||||
| -rw-r--r-- | lib/ur/option.ur | 5 | ||||
| -rw-r--r-- | lib/ur/option.urs | 1 | ||||
| -rw-r--r-- | src/c/http.c | 32 | ||||
| -rw-r--r-- | src/c/static.c | 1 | ||||
| -rw-r--r-- | src/c/urweb.c | 9 | ||||
| -rw-r--r-- | src/cjr_print.sml | 6 | ||||
| -rw-r--r-- | src/compiler.sig | 1 | ||||
| -rw-r--r-- | src/compiler.sml | 41 | ||||
| -rw-r--r-- | src/demo.sml | 7 | ||||
| -rw-r--r-- | src/elab_env.sig | 3 | ||||
| -rw-r--r-- | src/elab_env.sml | 93 | ||||
| -rw-r--r-- | src/elab_print.sml | 6 | ||||
| -rw-r--r-- | src/elaborate.sml | 69 | ||||
| -rw-r--r-- | src/main.mlton.sml | 3 | ||||
| -rw-r--r-- | src/settings.sig | 3 | ||||
| -rw-r--r-- | src/settings.sml | 19 | ||||
| -rw-r--r-- | src/source.sml | 2 | ||||
| -rw-r--r-- | src/source_print.sml | 10 | ||||
| -rw-r--r-- | src/sqlite.sml | 2 | ||||
| -rw-r--r-- | src/urweb.grm | 44 | ||||
| -rw-r--r-- | tests/malformed.ur | 3 | ||||
| -rw-r--r-- | tests/malformed.urp | 5 | ||||
| -rw-r--r-- | tests/sigInModule.ur | 8 | ||||
| -rw-r--r-- | tests/topLevelPattern.ur | 5 |
35 files changed, 391 insertions, 93 deletions
@@ -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> |