diff options
Diffstat (limited to 'src')
70 files changed, 4826 insertions, 805 deletions
diff --git a/src/bg_thread.dummy.sml b/src/bg_thread.dummy.sml new file mode 100644 index 00000000..699fa741 --- /dev/null +++ b/src/bg_thread.dummy.sml @@ -0,0 +1,9 @@ +(* + Dummy implementation. Threading is only supported in MLton. + All other implementations just immediately run the background tasks +*) +structure BgThread:> BGTHREAD = struct + fun queueBgTask filename f = f () + fun hasBgTasks () = false + fun runBgTaskForABit () = () +end diff --git a/src/bg_thread.mlton.sml b/src/bg_thread.mlton.sml new file mode 100644 index 00000000..91195940 --- /dev/null +++ b/src/bg_thread.mlton.sml @@ -0,0 +1,65 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) + +structure BgThread:> BGTHREAD = struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val topLevel: Thread.Runnable.t option ref = ref NONE + val currentRunningThreadIsForFileName: string ref = ref "" + (* FIFO queue: Max one task per fileName *) + val tasks: ((Thread.Runnable.t * string) list) ref = ref [] + fun hasBgTasks () = List.length (!tasks) > 0 + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + + fun done () = Thread.atomically + (fn () => + ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks)) + ; case !tasks of + [] => (setItimer Time.zeroTime + ; currentRunningThreadIsForFileName := "" + ; switch (fn _ => valOf (!topLevel))) + | t :: rest => (currentRunningThreadIsForFileName := #2 t + ; switch (fn _ => #1 t)))) + + fun queueBgTask fileName f = + let + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => done ()) + ; done ())), + ()) + in + case List.find (fn t => #2 t = fileName) (!tasks) of + NONE => tasks := (new f, fileName) :: (!tasks) + | SOME t => + (* Move existing task to front of list *) + tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks) + end + + fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) = + List.map (fn a => if f a then replacement else a ) l + fun runBgTaskForABit () = + case !(tasks) of + [] => () + | t :: rest => + (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime + (* This might some not needed, but other wise you get "Dead thread" error *) + ; tasks := replaceInList + (!tasks) + (fn t => #2 t = (!currentRunningThreadIsForFileName)) + (t, (!currentRunningThreadIsForFileName)) + ; currentRunningThreadIsForFileName := "" + ; valOf (!topLevel)))) + ; setItimer (Time.fromMilliseconds 200) + ; currentRunningThreadIsForFileName := #2 t + ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *) + ; setItimer Time.zeroTime + ) + end diff --git a/src/bg_thread.sig b/src/bg_thread.sig new file mode 100644 index 00000000..5455bbc8 --- /dev/null +++ b/src/bg_thread.sig @@ -0,0 +1,7 @@ +(* Notice: API is kinda bad. We only allow queuing a single task per file *) +(* This works for us because we only do elaboration in the background, nothing else *) +signature BGTHREAD = sig + val queueBgTask: string (* fileName *) -> (unit -> unit) -> unit + val hasBgTasks: unit -> bool + val runBgTaskForABit: unit -> unit +end diff --git a/src/c/Makefile.am b/src/c/Makefile.am index 58f5153c..ff4b6eaf 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -1,21 +1,26 @@ lib_LTLIBRARIES = liburweb.la liburweb_http.la liburweb_cgi.la liburweb_fastcgi.la liburweb_static.la -liburweb_la_SOURCES = memmem.c openssl.c urweb.c request.c queue.c +liburweb_la_SOURCES = memmem.c memmem.h openssl.c urweb.c request.c queue.c liburweb_http_la_SOURCES = http.c liburweb_cgi_la_SOURCES = cgi.c liburweb_fastcgi_la_SOURCES = fastcgi.c fastcgi.h liburweb_static_la_SOURCES = static.c -AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES) +AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES) $(ICU_INCLUDES) AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS) liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \ - -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' -liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) + -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 -licuio liburweb_http_la_LIBADD = liburweb.la -liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_cgi_la_LIBADD = liburweb.la -liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_fastcgi_la_LIBADD = liburweb.la -liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ + -version-info 1:0:0 liburweb_static_la_LIBADD = liburweb.la -liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_static_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 72685508..de2f1376 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -11,6 +11,7 @@ #include <unistd.h> #include <signal.h> #include <stdarg.h> +#include <sys/un.h> #include <pthread.h> @@ -65,6 +66,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,12 +77,13 @@ static void log_debug(void *data, const char *fmt, ...) { va_start(ap, fmt); vprintf(fmt, ap); + fflush(stdout); } } static uw_loggers ls = {NULL, log_error, log_debug}; -static unsigned max_buf_size = 1024 * 1024; // That's 1MB. +static unsigned max_buf_size = 10 * 1024 * 1024; // That's 10MB. static void *worker(void *data) { int me = *(int *)data; @@ -333,7 +336,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>] [-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); + printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-u <UNIX socket>] [-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) { @@ -346,6 +349,7 @@ union uw_sockaddr { struct sockaddr sa; struct sockaddr_in ipv4; struct sockaddr_in6 ipv6; + struct sockaddr_un un; }; int main(int argc, char *argv[]) { @@ -365,7 +369,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:m:")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:A:u:t:kqT:m:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option\n"); @@ -403,6 +407,15 @@ int main(int argc, char *argv[]) { } break; + case 'u': + my_addr.sa.sa_family = AF_UNIX; + if (!strncpy(my_addr.un.sun_path, optarg, sizeof(my_addr.un.sun_path)-1)) { + fprintf(stderr, "Invalid UNIX socket filename\n"); + help(argv[0]); + return 1; + } + break; + case 't': nthreads = atoi(optarg); if (nthreads <= 0) { @@ -472,6 +485,11 @@ int main(int argc, char *argv[]) { my_size = sizeof(my_addr.ipv6); my_addr.ipv6.sin6_port = htons(uw_port); break; + + case AF_UNIX: + unlink(my_addr.un.sun_path); + my_size = sizeof(my_addr.un); + break; } if (bind(sockfd, &my_addr.sa, my_size) < 0) { diff --git a/src/c/memmem.c b/src/c/memmem.c index f31f4e31..efddd0c1 100644 --- a/src/c/memmem.c +++ b/src/c/memmem.c @@ -1,4 +1,6 @@ -#include "config.h" +#include "memmem.h" + +#ifndef HAVE_MEMMEM /* $NetBSD$ */ @@ -38,8 +40,6 @@ * POSSIBILITY OF SUCH DAMAGE. */ -// Function renamed by Adam Chlipala in 2016. - #include <sys/cdefs.h> #if defined(LIBC_SCCS) && !defined(lint) __RCSID("$NetBSD$"); @@ -54,13 +54,8 @@ __RCSID("$NetBSD$"); #define NULL ((char *)0) #endif -/* - * urweb_memmem() returns the location of the first occurence of data - * pattern b2 of size len2 in memory block b1 of size len1 or - * NULL if none is found. - */ void * -urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2) +memmem(const void *b1, size_t len1, const void *b2, size_t len2) { /* Sanity check */ if(!(b1 != NULL && b2 != NULL && len1 != 0 && len2 != 0)) @@ -85,3 +80,5 @@ urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2) return NULL; } + +#endif // !defined(HAVE_MEMMEM) diff --git a/src/c/memmem.h b/src/c/memmem.h new file mode 100644 index 00000000..0ddbb494 --- /dev/null +++ b/src/c/memmem.h @@ -0,0 +1,23 @@ +#ifndef URWEB_MEMMEM_H +#define URWEB_MEMMEM_H + +#include "config.h" + +#ifdef HAVE_MEMMEM + +#include <string.h> + +#else // !defined(HAVE_MEMMEM) + +#include <stddef.h> + +/* + * memmem() returns the location of the first occurence of data + * pattern b2 of size len2 in memory block b1 of size len1 or + * NULL if none is found. + */ +void *memmem(const void *b1, size_t len1, const void *b2, size_t len2); + +#endif // !defined(HAVE_MEMMEM) + +#endif // URWEB_MEMMEM_H diff --git a/src/c/request.c b/src/c/request.c index 3e7ac34c..195b3cdc 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -11,13 +11,12 @@ #include <pthread.h> +#include "memmem.h" #include "urweb.h" #include "request.h" #define MAX_RETRIES 5 -void *urweb_memmem(const void *b1, size_t len1, const void *b2, size_t len2); - static int try_rollback(uw_context ctx, int will_retry, void *logger_data, uw_logger log_error) { int r = uw_rollback(ctx, will_retry); @@ -422,7 +421,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx, } } - part = urweb_memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len); + part = memmem(after_sub_headers, body + body_len - after_sub_headers, boundary, boundary_len); if (!part) { log_error(logger_data, "Missing boundary after multipart payload\n"); return FAILED; diff --git a/src/c/urweb.c b/src/c/urweb.c index e7efae38..0db5fc80 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,6 +20,10 @@ #include <pthread.h> +#include <unicode/utf8.h> +#include <unicode/ustring.h> +#include <unicode/uchar.h> + #include "types.h" #include "uthash.h" @@ -737,7 +741,10 @@ void uw_close(uw_context ctx) { } uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { - return ctx->get_header(ctx->get_header_data, h); + if (ctx->get_header) + return ctx->get_header(ctx->get_header_data, h); + else + return NULL; } void uw_set_headers(uw_context ctx, char *(*get_header)(void *, const char *), void *get_header_data) { @@ -896,9 +903,12 @@ char *uw_error_message(uw_context ctx) { return ctx->error_message; } -void uw_set_error_message(uw_context ctx, const char *msg) { - strncpy(ctx->error_message, msg, sizeof(ctx->error_message)); - ctx->error_message[sizeof(ctx->error_message)-1] = 0; +void uw_set_error_message(uw_context ctx, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap); + ctx->error_message[ERROR_BUF_LEN-1] = 0; } static input *INP(uw_context ctx) { @@ -1553,94 +1563,90 @@ const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { } } +uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char ch); + +static void jsifyChar(char **buffer_ptr, uw_context ctx, uw_Basis_char c1) { + char* buffer = *buffer_ptr; + + switch (c1) { + case '"': + strcpy(buffer, "\\\""); + buffer += 2; + break; + case '\'': + strcpy(buffer, "\\047"); + buffer += 4; + break; + case '\\': + strcpy(buffer, "\\\\"); + buffer += 2; + break; + case '<': + strcpy(buffer, "\\074"); + buffer += 4; + break; + case '&': + strcpy(buffer, "\\046"); + buffer += 4; + break; + default: + if (uw_Basis_isprint(ctx, c1)) { + int offset = 0; + U8_APPEND_UNSAFE(buffer, offset, c1); + buffer += offset; + } else { + if(65536 > c1) { + sprintf(buffer, "\\u%04x", c1); + buffer += 6; + } else { + sprintf(buffer, "\\u{%06x}", c1); + buffer += 10; + } + } + } + + *buffer_ptr = buffer; +} + uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; + uw_Basis_char c; - uw_check_heap(ctx, strlen(s) * 4 + 3); + uw_check_heap(ctx, strlen(s) * 10 + 3); r = s2 = ctx->heap.front; *s2++ = '"'; - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\'': - strcpy(s2, "\\047"); - s2 += 4; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - case '<': - strcpy(s2, "\\074"); - s2 += 4; - break; - case '&': - strcpy(s2, "\\046"); - s2 += 4; - break; - default: - if (isprint((int)c) || c >= 128) - *s2++ = c; - else { - sprintf(s2, "\\%03o", c); - s2 += 4; - } + int offset = 0; + while(s[offset] != 0) + { + U8_NEXT(s, offset, -1, c); + + jsifyChar(&s2, ctx, c); } - } strcpy(s2, "\""); ctx->heap.front = s2 + 2; + return r; } +uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c); + uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c1) { - unsigned char c = c1; char *r, *s2; - uw_check_heap(ctx, 7); + uw_check_heap(ctx, 10); r = s2 = ctx->heap.front; + *s2++ = '"'; - - switch (c) { - case '"': - strcpy(s2, "\\\""); - s2 += 2; - break; - case '\'': - strcpy(s2, "\\047"); - s2 += 4; - break; - case '\\': - strcpy(s2, "\\\\"); - s2 += 2; - break; - case '<': - strcpy(s2, "\\074"); - s2 += 4; - break; - case '&': - strcpy(s2, "\\046"); - s2 += 4; - break; - default: - if (isprint((int)c) || c >= 128) - *s2++ = c; - else { - sprintf(s2, "\\%03o", (unsigned char)c); - s2 += 4; - } - } + + jsifyChar(&s2, ctx, c1); strcpy(s2, "\""); ctx->heap.front = s2 + 2; + return r; } @@ -1684,6 +1690,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { strcpy(s2, "\""); ctx->script.front = s2 + 1; + return r; } @@ -1951,29 +1958,61 @@ char *uw_Basis_urlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } +static void aux_urlifyChar(char** ptr, uw_Basis_char c) { + char* p = *ptr; + + if((uint32_t)(c) <= 0x7f) { + sprintf(p, ".%02X", (uint8_t)(c)); + p += 3; + } else { + if((uint32_t)(c) <= 0x7ff) { + sprintf(p, ".%02X", (uint8_t)(((c)>>6)|0xc0)); + p += 3; + } else { + if((uint32_t)(c) <= 0xffff) { + sprintf(p, ".%02X", (uint8_t)(((c)>>12)|0xe0)); + p += 3; + } else { + sprintf(p, ".%02X", (uint8_t)(((c)>>18)|0xf0)); + p += 3; + sprintf(p, ".%02X", (uint8_t)((((c)>>12)&0x3f)|0x80)); + p += 3; + } + sprintf(p, ".%02X", (uint8_t)((((c)>>6)&0x3f)|0x80)); + p += 3; + } + sprintf(p, ".%02X", (uint8_t)(((c)&0x3f)|0x80)); + p += 3; + } + + *ptr = p; +} + char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) { char *r, *p; if (s[0] == '\0') return "_"; - uw_check_heap(ctx, strlen(s) * 3 + 1 + !!(s[0] == '_')); + uw_check_heap(ctx, strlen(s) * 12 + 1 + !!(s[0] == '_')); r = p = ctx->heap.front; if (s[0] == '_') *p++ = '_'; - for (; *s; s++) { - unsigned char c = *s; - - if (c == ' ') + uw_Basis_char c; + int offset = 0, curr = 0; + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + + if (U8_IS_SINGLE(s[curr]) && s[curr] == ' ') *p++ = '+'; - else if (isalnum(c)) - *p++ = c; + else if (U8_IS_SINGLE(s[curr]) && isalnum(s[curr])) + *p++ = s[curr]; else { - sprintf(p, ".%02X", c); - p += 3; + aux_urlifyChar(&p, c); } + curr = offset; } *p++ = 0; @@ -1983,7 +2022,7 @@ char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) { char *uw_Basis_urlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "0"; else return "1"; @@ -2043,6 +2082,29 @@ uw_unit uw_Basis_urlifyTime_w(uw_context ctx, uw_Basis_time t) { return uw_Basis_urlifyInt_w(ctx, (uw_Basis_int)t.seconds * 1000000 + t.microseconds); } +uw_unit uw_Basis_urlifyChar_w(uw_context ctx, uw_Basis_char c) { + if (c == '\0') { + uw_check(ctx, 1); + uw_writec_unsafe(ctx, '_'); + return uw_unit_v; + } + + uw_check(ctx, 12 + !!(c == '_')); + + if (c == '_') + uw_writec_unsafe(ctx, '_'); + + if (c == ' ') + uw_writec_unsafe(ctx, '+'); + else if (isalnum(c) && c <= 0x7f) + uw_writec_unsafe(ctx, c); + else { + aux_urlifyChar(&(ctx->page.front), c); + } + + return uw_unit_v; +} + uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { if (s[0] == '\0') { uw_check(ctx, 1); @@ -2050,29 +2112,31 @@ uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } - uw_check(ctx, strlen(s) * 3 + !!(s[0] == '_')); + uw_check(ctx, strlen(s) * 12 + !!(s[0] == '_')); if (s[0] == '_') uw_writec_unsafe(ctx, '_'); - for (; *s; s++) { - unsigned char c = *s; - - if (c == ' ') + uw_Basis_char c; + int offset = 0, curr = 0; + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + + if (U8_IS_SINGLE(s[curr]) && s[curr] == ' ') uw_writec_unsafe(ctx, '+'); - else if (isalnum(c)) - uw_writec_unsafe(ctx, c); - else { - sprintf(ctx->page.front, ".%02X", c); - ctx->page.front += 3; + else if (U8_IS_SINGLE(s[curr]) && isalnum(s[curr])) + uw_writec_unsafe(ctx, s[curr]); + else { + aux_urlifyChar(&(ctx->page.front), c); } + curr = offset; } return uw_unit_v; } uw_unit uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) { - if (b == uw_Basis_False) + if (!b) uw_writec(ctx, '0'); else uw_writec(ctx, '1'); @@ -2207,6 +2271,23 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context ctx, char **s) { return r; } +uw_Basis_char uw_Basis_unurlifyChar(uw_context ctx, char **s) { + char *new_s = uw_unurlify_advance(*s); + char *r; + int len; + + len = strlen(*s); + uw_check_heap(ctx, len + 1); + + r = ctx->heap.front; + ctx->heap.front = uw_unurlifyString_to(0, ctx, ctx->heap.front, *s); + *s = new_s; + if (strlen(r) == 1) + return r[0]; + else + uw_error(ctx, FATAL, "Unurlified character is multiple characters long"); +} + uw_Basis_unit uw_Basis_unurlifyUnit(uw_context ctx, char **s) { (void)ctx; *s = uw_unurlify_advance(*s); @@ -2249,25 +2330,40 @@ uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { return uw_unit_v; } -char *uw_Basis_htmlifySpecialChar(uw_context ctx, unsigned char ch) { +char *uw_Basis_htmlifySpecialChar(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; int len; char *r; - uw_check_heap(ctx, INTS_MAX+3); + uw_check_heap(ctx, INTS_MAX+3 + 1); r = ctx->heap.front; - sprintf(r, "&#%u;%n", n, &len); + len = sprintf(r, "&#%u;", n); ctx->heap.front += len+1; + return r; } -uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, unsigned 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); - sprintf(ctx->page.front, "&#%u;%n", n, &len); + + 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; } @@ -2315,23 +2411,35 @@ uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_int n) { char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { char *r, *s2; + uw_Basis_char c1; + int oldoffset = 0, offset = 0, offset2 = 0, len = 0; + + uw_check_heap(ctx, strlen(s) * (INTS_MAX + 3) + 1); - uw_check_heap(ctx, strlen(s) * 5 + 1); - - for (r = s2 = ctx->heap.front; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - strcpy(s2, "<"); - s2 += 4; - break; - case '&': - strcpy(s2, "&"); - s2 += 5; - break; - default: - *s2++ = c; + r = s2 = ctx->heap.front; + + while (s[offset] != 0) { + oldoffset = offset; + U8_NEXT(s, offset, -1, c1); + + if ((offset - oldoffset == 1) && uw_Basis_isprint(ctx, c1)) { + switch (c1) { + case '<': + strcpy(s2, "<"); + s2 += 4; + break; + case '&': + strcpy(s2, "&"); + s2 += 5; + break; + default: + offset2 = 0; + U8_APPEND_UNSAFE(s2, offset2, c1); + s2 += offset2; + } + } else { + len = sprintf(s2, "&#%u;", c1); + s2 += len; } } @@ -2342,20 +2450,29 @@ char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 6); - - for (; *s; s++) { - unsigned char c = *s; - - switch (c) { - case '<': - uw_write_unsafe(ctx, "<"); - break; - case '&': - uw_write_unsafe(ctx, "&"); - break; - default: - uw_writec_unsafe(ctx, c); + int offset = 0, oldoffset = 0; + uw_Basis_char c1; + + while(s[offset] != 0){ + oldoffset = offset; + U8_NEXT(s, offset, -1, c1); + + if ((offset - oldoffset == 1) && uw_Basis_isprint(ctx, c1)) { + + switch (c1) { + case '<': + uw_write_unsafe(ctx, "<"); + break; + case '&': + uw_write_unsafe(ctx, "&"); + break; + default: + uw_writec_unsafe(ctx, c1); + } } + else { + uw_Basis_htmlifySpecialChar_w(ctx, c1); + } } return uw_unit_v; @@ -2363,14 +2480,14 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "False"; else return "True"; } uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { - if (b == uw_Basis_False) { + if (!b) { uw_check(ctx, 6); strcpy(ctx->page.front, "False"); ctx->page.front += 5; @@ -2419,27 +2536,33 @@ uw_unit uw_Basis_htmlifySource_w(uw_context ctx, uw_Basis_source src) { } uw_Basis_char uw_Basis_strsub(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + uw_Basis_char c; + int offset = 0; + while (n >= 0) { - if (*s == 0) + + if (s[offset] == 0) uw_error(ctx, FATAL, "Out-of-bounds strsub"); + U8_NEXT(s, offset, -1, c); + if (n == 0) - return *s; + return c; --n; - ++s; } uw_error(ctx, FATAL, "Negative strsub bound"); } uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + int offset = 0; while (n >= 0) { - if (*s == 0 || n == 0) - return s; + if (s[offset] == 0 || n == 0) + return s + offset; + U8_FWD_1(s, offset, -1); --n; - ++s; } uw_error(ctx, FATAL, "Negative strsuffix bound"); @@ -2447,40 +2570,81 @@ uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_i uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) { (void)ctx; - return strlen(s); + int offset = 0, iterations = 0; + while (s[offset] != 0) { + U8_FWD_1(s, offset, -1); + ++iterations; + } + return iterations; } uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { (void)ctx; - + int offset = 0; while (n > 0) { - if (*s == 0) + if (s[offset] == 0) return uw_Basis_False; - + + U8_FWD_1(s, offset, -1); --n; - ++s; } return uw_Basis_True; } +static int aux_strchr(uw_Basis_string s, uw_Basis_char ch, int *o_offset) { + int u8idx = 0, offset = 0, offsetpr = 0; + uw_Basis_char c; + + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + if (c == ch) { + *o_offset = offsetpr; + return u8idx; + } + + offsetpr = offset; + ++u8idx; + } + + *o_offset = -1; + return -1; +} + uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { (void)ctx; - return strchr(s, ch); + int offset = -1; + if (aux_strchr(s, ch, &offset) > -1) { + return s + offset; + } + return NULL; } uw_Basis_int uw_Basis_strcspn(uw_context ctx, uw_Basis_string s, uw_Basis_string chs) { (void)ctx; - return strcspn(s, chs); + int offset = 0, u8idx = 0, offsetChs = 0; + uw_Basis_char c; + + while (s[offset] != 0) { + U8_NEXT(s, offset, -1, c); + if (aux_strchr(chs, c, &offsetChs) > -1) { + return u8idx; + } + ++u8idx; + } + + return u8idx; } uw_Basis_int *uw_Basis_strindex(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { - uw_Basis_string r = strchr(s, ch); - if (r == NULL) + (void)ctx; + int offset = -1; + int r = aux_strchr(s, ch, &offset); + if (r == -1) return NULL; else { uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); - *nr = r - s; + *nr = r; return nr; } } @@ -2491,13 +2655,19 @@ uw_Basis_int *uw_Basis_strsindex(uw_context ctx, const char *haystack, const cha return NULL; else { uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); - *nr = r - haystack; + int src = r - haystack, offset = 0, utf8idx = 0; + while (offset < src) { + U8_FWD_1(haystack, offset, -1); + ++utf8idx; + } + + *nr = utf8idx; return nr; } } uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { - int len = uw_Basis_strlen(ctx, s1) + uw_Basis_strlen(ctx, s2) + 1; + int len = strlen(s1) + strlen(s2) + 1; char *s; uw_check_heap(ctx, len); @@ -2512,8 +2682,8 @@ uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_str } uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_int start, uw_Basis_int len) { - size_t full_len = uw_Basis_strlen(ctx, s); - + int full_len = uw_Basis_strlen(ctx, s); + if (start < 0) uw_error(ctx, FATAL, "substring: Negative start index"); if (len < 0) @@ -2521,32 +2691,53 @@ uw_Basis_string uw_Basis_substring(uw_context ctx, uw_Basis_string s, uw_Basis_i if (start + len > full_len) uw_error(ctx, FATAL, "substring: Start index plus length is too large"); - if (start + len == full_len) - return &s[start]; - else { - uw_Basis_string r = uw_malloc(ctx, len+1); - memcpy(r, s+start, len); - r[len] = 0; + int offset = 0; + U8_FWD_N(s, offset, -1, start); + + if (start + len == full_len) { + return s + offset; + } else { + int end = offset; + U8_FWD_N(s, end, -1, len); + + int actual_len = end - offset; + + uw_Basis_string r = uw_malloc(ctx, actual_len + 1); + memcpy(r, s + offset, actual_len); + r[actual_len] = 0; return r; } - } uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) { char *r; - - uw_check_heap(ctx, 2); + int req = U8_LENGTH(ch); + int offset = 0; + + uw_check_heap(ctx, req + 1); r = ctx->heap.front; - r[0] = ch; - r[1] = 0; - ctx->heap.front += 2; + U8_APPEND_UNSAFE(r, offset, ch); + r[req] = 0; - return r; + ctx->heap.front += req + 1; + 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 = uw_Basis_strlen(ctx, s1) + 1; + int len = strlen(s1) + 1; char *s; uw_check_heap(ctx, len); @@ -2673,7 +2864,6 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { uw_Basis_string uw_Basis_sqlifyChar(uw_context ctx, uw_Basis_char c) { char *r, *s2; - uw_check_heap(ctx, 5 + uw_Estrings + strlen(uw_sqlsuffixChar)); r = s2 = ctx->heap.front; @@ -2818,7 +3008,7 @@ uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "FALSE"; else return "TRUE"; @@ -2902,7 +3092,7 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; - if (b == uw_Basis_False) + if (!b) return (char *)&false; else return (char *)&true; @@ -2931,15 +3121,12 @@ uw_Basis_string uw_Basis_floatToString(uw_context ctx, uw_Basis_float n) { } uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) { - char *r = uw_malloc(ctx, 2); - r[0] = ch; - r[1] = 0; - return r; + return uw_Basis_str1(ctx, ch); } uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { (void)ctx; - if (b == uw_Basis_False) + if (!b) return "False"; else return "True"; @@ -2994,11 +3181,12 @@ uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) { uw_Basis_char *r = uw_malloc(ctx, 1); r[0] = 0; return r; - } else if (s[1] != 0) + } else if (uw_Basis_strlenGe(ctx, s, 2)) return NULL; else { uw_Basis_char *r = uw_malloc(ctx, 1); - r[0] = s[0]; + int offset = 0; + U8_NEXT(s, offset, -1, *r); return r; } } @@ -3123,10 +3311,14 @@ uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) { uw_Basis_char uw_Basis_stringToChar_error(uw_context ctx, uw_Basis_string s) { if (s[0] == 0) return 0; - else if (s[1] != 0) + else if (uw_Basis_strlenGe(ctx, s, 2)) uw_error(ctx, FATAL, "Can't parse char: %s", uw_Basis_htmlifyString(ctx, s)); - else - return s[0]; + else { + uw_Basis_char c; + int offset = 0; + U8_NEXT(s, offset, -1, c); + return c; + } } uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { @@ -3229,10 +3421,19 @@ uw_Basis_blob uw_Basis_stringToBlob_error(uw_context ctx, uw_Basis_string s, siz s += 2; while (*s) { + char a = s[0]; + s += 1; + char b; + if (*s){ + b = s[0]; + } else { + b = 0; + } int n; - sscanf(s, "%02x", &n); + char buf[3] = {a, b, 0}; + n = strtol(buf, NULL, 16); *r++ = n; - s += 2; + s += 1; } } else { while (*s) { @@ -3986,6 +4187,20 @@ uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { return b; } +uw_Basis_string uw_Basis_textOfBlob(uw_context ctx, uw_Basis_blob b) { + size_t i; + uw_Basis_string r; + + for (i = 0; i < b.size; ++i) + if (b.data[i] == 0) + return NULL; + + r = uw_malloc(ctx, b.size + 1); + memcpy(r, b.data, b.size); + r[b.size] = 0; + return r; +} + uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { (void)ctx; return f.data; @@ -4235,7 +4450,7 @@ uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_ struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day, .tm_hour = hour, .tm_min = minute, .tm_sec = second, .tm_isdst = -1 }; - uw_Basis_time r = { timelocal(&tm) }; + uw_Basis_time r = { mktime(&tm) }; return r; } @@ -4325,88 +4540,108 @@ void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*)) uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isalnum((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_ALNUM); } uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isalpha((int)c); + return !!u_hasBinaryProperty(c, UCHAR_ALPHABETIC); } uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isblank((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_BLANK); } uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!iscntrl((int)c); + return !!(u_charType(c)==U_CONTROL_CHAR); } uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isdigit((int)c); + return !!u_isdigit(c); } uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isgraph((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_GRAPH); } uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!islower((int)c); + return !!u_hasBinaryProperty(c, UCHAR_LOWERCASE); } uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isprint((int)c); + return !!u_hasBinaryProperty(c, UCHAR_POSIX_PRINT); } uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!ispunct((int)c); + return !!u_ispunct(c); } uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isspace((int)c); + return !!u_hasBinaryProperty(c, UCHAR_WHITE_SPACE); } uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isupper((int)c); + return !!u_hasBinaryProperty(c, UCHAR_UPPERCASE); } uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) { (void)ctx; - return !!isxdigit((int)c); + return !!(c <= 0x7f && u_isxdigit(c)); } uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) { (void)ctx; - return tolower((int)c); + return u_tolower(c); } uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) { (void)ctx; - return toupper((int)c); + return u_toupper(c); } uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) { (void)ctx; - return (unsigned char)c; + return (uw_Basis_int)c; +} + +uw_Basis_bool uw_Basis_iscodepoint(uw_context ctx, uw_Basis_int n) { + (void)ctx; + return !!(n <= 0x10FFFF); +} + +uw_Basis_bool uw_Basis_issingle(uw_context ctx, uw_Basis_char c) { + (void)ctx; + return !!(c < 128); } uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { (void)ctx; - return n; + uw_Basis_char ch = (uw_Basis_char)n; + + if (n > 0x10FFFF) { + uw_error(ctx, FATAL, "The integer %lld is not a valid char codepoint", n); + } + + return ch; } uw_Basis_string uw_Basis_currentUrl(uw_context ctx) { return ctx->current_url; } +uw_Basis_string uw_Basis_anchorUrl(uw_context ctx, uw_Basis_string s) { + return uw_Basis_strcat(ctx, uw_Basis_strcat(ctx, ctx->current_url, "#"), s); +} + void uw_set_currentUrl(uw_context ctx, char *s) { ctx->current_url = s; } @@ -4654,7 +4889,7 @@ uw_Basis_string uw_Basis_atom(uw_context ctx, uw_Basis_string s) { for (p = s; *p; ++p) { char c = *p; - if (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#') + if (!U8_IS_SINGLE(c) || (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#')) uw_error(ctx, FATAL, "Disallowed character in CSS atom"); } @@ -4666,8 +4901,8 @@ uw_Basis_string uw_Basis_css_url(uw_context ctx, uw_Basis_string s) { for (p = s; *p; ++p) { char c = *p; - if (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' - && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#') + if (!U8_IS_SINGLE(c) || (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' + && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#')) uw_error(ctx, FATAL, "Disallowed character in CSS URL"); } @@ -4680,12 +4915,12 @@ uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) { if (!*s) uw_error(ctx, FATAL, "Empty CSS property"); - if (!islower((int)s[0]) && s[0] != '_') + if (!U8_IS_SINGLE(s[0]) || (!islower((int)s[0]) && s[0] != '_')) uw_error(ctx, FATAL, "Bad initial character in CSS property"); for (p = s; *p; ++p) { char c = *p; - if (!islower((int)c) && !isdigit((int)c) && c != '_' && c != '-') + if (!U8_IS_SINGLE(c) || (!islower((int)c) && !isdigit((int)c) && c != '_' && c != '-')) uw_error(ctx, FATAL, "Disallowed character in CSS property"); } @@ -4719,13 +4954,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"); @@ -4738,7 +4973,7 @@ uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) { char *p = s; for (; *p; ++p) - if (!isalnum(*p) && *p != '-' && *p != '_') + if (!U8_IS_SINGLE(*p) || (!isalnum(*p) && *p != '-' && *p != '_')) uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s); return s; @@ -5070,7 +5305,7 @@ int strcmp_nullsafe(const char *str1, const char *str2) { static int is_valid_hash(uw_Basis_string hash) { for (; *hash; ++hash) - if (!isxdigit(*hash)) + if (!U8_IS_SINGLE(*hash) || !isxdigit(*hash)) return 0; return 1; @@ -5102,7 +5337,7 @@ uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { fd = mkstemp(tempfile); if (fd < 0) - uw_error(ctx, FATAL, "Error creating temporary file for cache"); + uw_error(ctx, FATAL, "Error creating temporary file %s for cache", tempfile); while (written_so_far < contents.size) { ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); @@ -5134,9 +5369,8 @@ uw_Basis_blob uw_Basis_check_filecache(uw_context ctx, uw_Basis_string hash) { // Hashes come formatted for printing by Postgres, which means they start with // two extra characters. Let's remove them. - if (!hash[0] || !hash[1]) - uw_error(ctx, FATAL, "Hash to check against file cache came in not in Postgres format: %s", hash); - hash += 2; + if (hash[0] == '\\' && hash[1] == 'x') + hash += 2; if (!dir) uw_error(ctx, FATAL, "Checking file cache when no directory is set"); 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 87d2576c..70ebdf43 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -952,7 +952,7 @@ fun unurlify fromClient env (t, loc) = newline, string ":", space, - string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"), + string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", *request), NULL))));"), newline], string "}", newline, @@ -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) @@ -2550,8 +2537,10 @@ fun p_decl env (dAll as (d, loc) : decl) = (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 = name} + val js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), + file = name} + val () = app_js := js + val () = Endpoints.setJavaScript js in box [string "static char jslib[] = \"", string (Prim.toCString s), @@ -3241,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 @@ -3345,9 +3335,20 @@ fun p_file env (ds, ps) = string "}", newline] - val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds - val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds - val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds + val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => + SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e) + | _ => NONE) ds + val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => + SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) + x2 dummyt) e) + | _ => NONE) ds + val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => + SOME (n, x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e) + | _ => NONE) ds + + val (protos', defs') = ListPair.unzip (latestUrlHandlers ()) + val protos = protos @ protos' + val defs = defs @ defs' val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds @@ -3380,6 +3381,14 @@ fun p_file env (ds, ps) = newline, string "#include <time.h>", newline, + (case Settings.getFileCache () of + NONE => box [] + | SOME _ => box [string "#include <sys/types.h>", + newline, + string "#include <sys/stat.h>", + newline, + string "#include <unistd.h>", + newline]), if hasDb then box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] @@ -3467,7 +3476,7 @@ fun p_file env (ds, ps) = newline, newline, - box (ListUtil.mapi (fn (i, (_, x1, x2, e)) => + box (ListUtil.mapi (fn (i, (_, x1, x2, pe)) => box [string "static void uw_periodic", string (Int.toString i), string "(uw_context ctx) {", @@ -3478,7 +3487,7 @@ fun p_file env (ds, ps) = string x2, string "_1 = 0;", newline, - p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, + pe, string ";", newline], string "}", @@ -3617,22 +3626,21 @@ fun p_file env (ds, ps) = box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {", newline, - p_list_sep (box []) (fn (x1, x2, e) => box [string "({", - newline, - string "uw_Basis_client __uwr_", - string x1, - string "_0 = cli;", - newline, - string "uw_unit __uwr_", - string x2, - string "_1 = 0;", - newline, - p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan)) - x2 dummyt) e, - string ";", - newline, - string "});", - newline]) expungers, + p_list_sep (box []) (fn (x1, x2, pe) => box [string "({", + newline, + string "uw_Basis_client __uwr_", + string x1, + string "_0 = cli;", + newline, + string "uw_unit __uwr_", + string x2, + string "_1 = 0;", + newline, + pe, + string ";", + newline, + string "});", + newline]) expungers, if hasDb then box [p_enamed env (!expunge), @@ -3645,24 +3653,38 @@ fun p_file env (ds, ps) = newline, string "static void uw_initializer(uw_context ctx) {", newline, - box [string "uw_begin_initializing(ctx);", + box [(case Settings.getFileCache () of + NONE => box [] + | SOME dir => box [newline, + string "struct stat st = {0};", + newline, + newline, + string "if (stat(\"", + string (Prim.toCString dir), + string "\", &st) == -1)", + newline, + box [string "mkdir(\"", + string (Prim.toCString dir), + string "\", 0700);", + newline]]), + string "uw_begin_initializing(ctx);", newline, p_list_sep newline (fn x => x) (rev (!global_initializers)), string "uw_end_initializing(ctx);", newline, - p_list_sep (box []) (fn (x1, x2, e) => box [string "({", - newline, - string "uw_unit __uwr_", - string x1, - string "_0 = 0, __uwr_", - string x2, - string "_1 = 0;", - newline, - p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e, - string ";", - newline, - string "});", - newline]) initializers, + p_list_sep (box []) (fn (x1, x2, pe) => box [string "({", + newline, + string "uw_unit __uwr_", + string x1, + string "_0 = 0, __uwr_", + string x2, + string "_1 = 0;", + newline, + pe, + string ";", + newline, + string "});", + newline]) initializers, if hasDb then box [p_enamed env (!initialize), string "(ctx, 0);", @@ -3710,8 +3732,30 @@ fun p_file env (ds, ps) = newline] end +fun isText t = + case t of + String => true + | Nullable t => isText t + | _ => false + +fun declaresAsForeignKey xs s = + case String.tokens (fn ch => Char.isSpace ch orelse ch = #"," orelse ch = #"(" orelse ch = #")") s of + "FOREIGN" :: "KEY" :: rest => + let + fun consume rest = + case rest of + [] => false + | "REFERENCES" :: _ => false + | xs' :: rest' => xs' = xs orelse consume rest' + in + consume rest + end + | _ => false + fun p_sql env (ds, _) = let + val usesSimilar = ref false + val (pps, _) = ListUtil.foldlMap (fn (dAll as (d, _), env) => let @@ -3722,14 +3766,28 @@ fun p_sql env (ds, _) = string "(", p_list (fn (x, t) => let + val xs = Settings.mangleSql (CharVector.map Char.toLower x) val t = sql_type_in env t + + val ts = if #textKeysNeedLengths (Settings.currentDbms ()) andalso isText t + andalso (List.exists (declaresAsForeignKey xs o #2) csts + orelse List.exists (String.isSubstring (xs ^ "(255)")) (pk :: map #2 csts)) then + "varchar(255)" + else + #p_sql_type (Settings.currentDbms ()) t in - box [string (Settings.mangleSql (CharVector.map Char.toLower x)), + box [string xs, space, - string (#p_sql_type (Settings.currentDbms ()) t), + string ts, case t of Nullable _ => box [] - | _ => string " NOT NULL"] + | _ => string " NOT NULL", + case t of + Time => if #requiresTimestampDefaults (Settings.currentDbms ()) then + string " DEFAULT CURRENT_TIMESTAMP" + else + box [] + | _ => box []] end) xts, case (pk, csts) of ("", []) => box [] @@ -3737,7 +3795,12 @@ fun p_sql env (ds, _) = cut, case pk of "" => box [] - | _ => box [string "PRIMARY", + | _ => box [string "CONSTRAINT", + space, + string s, + string "_pkey", + space, + string "PRIMARY", space, string "KEY", space, @@ -3777,13 +3840,29 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DDatabase {usesSimilar = s, ...} => + (usesSimilar := s; + box []) | _ => box [] in (pp, E.declBinds env dAll) end) env ds in - box (string (#sqlPrefix (Settings.currentDbms ())) :: pps) + box ((case Settings.getFileCache () of + NONE => [] + | SOME _ => case #supportsSHA512 (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512"; + []) + | SOME 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 end diff --git a/src/compiler.sig b/src/compiler.sig index bcf69fd4..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,6 +35,7 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -61,6 +62,7 @@ signature COMPILER = sig dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, @@ -115,6 +117,7 @@ signature COMPILER = sig val css : (Core.file, Css.report) phase val monoize : (Core.file, Mono.file) phase val mono_opt : (Mono.file, Mono.file) phase + val endpoints : (Mono.file, Mono.file) phase val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase @@ -163,12 +166,14 @@ signature COMPILER = sig val toUnpoly2 : (string, Core.file) transform val toShake4'' : (string, Core.file) transform val toEspecialize3 : (string, Core.file) transform + val toSpecialize3 : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake5 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform val toEffectize : (string, Core.file) transform val toCss : (string, Css.report) transform val toMonoize : (string, Mono.file) transform + val toEndpoints : (string, Mono.file) transform val toMono_opt1 : (string, Mono.file) transform val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index f724bf56..9cbe9949 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -39,6 +39,7 @@ type job = { sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -65,6 +66,7 @@ type job = { dbms : string option, sigFile : string option, fileCache : string option, + safeGetDefault : bool, safeGets : string list, onError : (string * string list * string) option, minHeap : int, @@ -274,7 +276,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job ({prefix, database, exe, sql, sources, debug, profile, +fun p_job ({prefix, database, exe, sql, endpoints, sources, debug, profile, timeout, ffi, link, headers, scripts, clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let @@ -303,6 +305,10 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, NONE => string "No SQL file." | SOME sql => string ("SQL fle: " ^ sql), newline, + case endpoints of + NONE => string "No endpoints file." + | SOME ep => string ("Endpoints fle: " ^ ep), + newline, string "Timeout: ", string (Int.toString timeout), newline, @@ -385,6 +391,7 @@ fun institutionalizeJob (job : job) = Settings.setMetaRules (#filterMeta job); Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); + Settings.setSafeGetDefault (#safeGetDefault job); Settings.setSafeGets (#safeGets job); Settings.setOnError (#onError job); Settings.setMinHeap (#minHeap job); @@ -441,6 +448,7 @@ fun parseUrp' accLibs fname = sources = [fname], exe = fname ^ ".exe", sql = NONE, + endpoints = Settings.getEndpoints (), debug = Settings.getDebug (), profile = false, timeout = 120, @@ -470,6 +478,7 @@ fun parseUrp' accLibs fname = dbms = NONE, sigFile = NONE, fileCache = NONE, + safeGetDefault = false, safeGets = [], onError = NONE, minHeap = 0, @@ -578,6 +587,7 @@ fun parseUrp' accLibs fname = val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) + val endpoints = ref (Settings.getEndpoints ()) val debug = ref (Settings.getDebug ()) val profile = ref false val timeout = ref NONE @@ -605,6 +615,7 @@ fun parseUrp' accLibs fname = val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) val fileCache = ref (Settings.getFileCache ()) + val safeGetDefault = ref false val safeGets = ref [] val onError = ref NONE val minHeap = ref 0 @@ -618,6 +629,7 @@ fun parseUrp' accLibs fname = exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = !sql, + endpoints = !endpoints, debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), @@ -645,6 +657,7 @@ fun parseUrp' accLibs fname = dbms = !dbms, sigFile = !sigFile, fileCache = !fileCache, + safeGetDefault = !safeGetDefault, safeGets = rev (!safeGets), onError = !onError, minHeap = !minHeap, @@ -679,6 +692,7 @@ fun parseUrp' accLibs fname = database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, + endpoints = #endpoints old, debug = #debug old orelse #debug new, profile = #profile old orelse #profile new, timeout = #timeout old, @@ -708,6 +722,7 @@ fun parseUrp' accLibs fname = dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), fileCache = mergeO #2 (#fileCache old, #fileCache new), + safeGetDefault = #safeGetDefault old orelse #safeGetDefault new, safeGets = #safeGets old @ #safeGets new, onError = mergeO #2 (#onError old, #onError new), minHeap = Int.max (#minHeap old, #minHeap new), @@ -730,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 = @@ -829,6 +844,7 @@ fun parseUrp' accLibs fname = | "include" => headers := relifyA arg :: !headers | "script" => scripts := arg :: !scripts | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "safeGetDefault" => safeGetDefault := true | "safeGet" => safeGets := arg :: !safeGets | "effectful" => effectful := ffiS () :: !effectful | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful @@ -937,7 +953,7 @@ fun parseUrp' accLibs fname = uri :: fname :: rest => (Settings.setFilePath thisPath; Settings.addFile {Uri = uri, - LoadFromFilename = fname, + LoadFromFilename = pathify fname, MimeType = case rest of [] => NONE | [ty] => SOME ty @@ -948,7 +964,7 @@ fun parseUrp' accLibs fname = | "jsFile" => (Settings.setFilePath thisPath; - Settings.addJsFile arg) + Settings.addJsFile (pathify arg)) | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () @@ -1184,6 +1200,7 @@ val parse = { else (); ErrorMsg.error ("Missing source file: " ^ fname); + anyErrors := true; (Source.DSequence "", ErrorMsg.dummySpan)) val dsFfi = map parseFfi ffi @@ -1266,7 +1283,7 @@ val elaborate = { in Elaborate.elabFile basis (OS.FileSys.modTime basisF) topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) - ElabEnv.empty file + ElabEnv.empty (fn env => env) file end, print = ElabPrint.p_file ElabEnv.empty } @@ -1383,8 +1400,9 @@ val toUnpoly2 = transform unpoly "unpoly2" o toShake4' val toSpecialize2 = transform specialize "specialize2" o toUnpoly2 val toShake4'' = transform shake "shake4'" o toSpecialize2 val toEspecialize3 = transform especialize "especialize3" o toShake4'' +val toSpecialize3 = transform specialize "specialize3" o toEspecialize3 -val toReduce2 = transform reduce "reduce2" o toEspecialize3 +val toReduce2 = transform reduce "reduce2" o toSpecialize3 val toShake5 = transform shake "shake5" o toReduce2 @@ -1421,7 +1439,14 @@ val mono_opt = { print = MonoPrint.p_file MonoEnv.empty } -val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize +val endpoints = { + func = Endpoints.collect, + print = MonoPrint.p_file MonoEnv.empty +} + +val toEndpoints = transform endpoints "endpoints" o toMonoize + +val toMono_opt1 = transform mono_opt "mono_opt1" o toEndpoints val untangle = { func = Untangle.untangle, @@ -1585,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.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" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic + proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ + !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" @@ -1598,6 +1627,7 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value" ^ opt ^ " -I " ^ !Settings.configInclude + ^ " " ^ !Settings.configIcuIncludes ^ " " ^ #compile proto ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname @@ -1710,6 +1740,18 @@ fun compile job = TextIO.closeOut outf end; + case #endpoints job of + NONE => () + | SOME endpoints => + let + val report = Endpoints.summarize () + val outf = TextIO.openOut endpoints + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (Endpoints.p_report report); + TextIO.closeOut outf + end; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} diff --git a/src/config.sig b/src/config.sig index a3ad7d76..be72a8cc 100644 --- a/src/config.sig +++ b/src/config.sig @@ -20,4 +20,7 @@ signature CONFIG = sig val pthreadCflags : string val pthreadLibs : string + + val icuIncludes : string + val icuLibs : string end diff --git a/src/config.sml.in b/src/config.sml.in index ebcdb7b6..2d12e28d 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -28,6 +28,9 @@ val pgheader = "@PGHEADER@" val msheader = "@MSHEADER@" val sqheader = "@SQHEADER@" +val icuIncludes = "@ICU_INCLUDES@" +val icuLibs = "@ICU_LIBS@" + val versionNumber = "@VERSION@" val versionString = "The Ur/Web compiler, version " ^ versionNumber diff --git a/src/core_util.sig b/src/core_util.sig index 835577a3..8d295f1e 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -161,6 +161,12 @@ structure Decl : sig decl : (Core.decl', 'state, 'abort) Search.mapfolder} -> (Core.decl, 'state, 'abort) Search.mapfolder + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp', + decl : Core.decl' -> Core.decl'} + -> Core.decl -> Core.decl + val fold : {kind : Core.kind' * 'state -> 'state, con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state, diff --git a/src/core_util.sml b/src/core_util.sml index 57ef16f7..d1d3d9c4 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -1029,6 +1029,22 @@ fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} = decl = fn () => fd, bind = fn ((), _) => ()} () +fun mapB {kind, con, exp, decl, bind} ctx d = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), + decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()), + bind = bind} ctx d () of + S.Continue (d, ()) => d + | S.Return _ => raise Fail "CoreUtil.Decl.mapB: Impossible" + +fun map {kind, con, exp, decl} d = + mapB {kind = fn () => kind, + con = fn () => con, + exp = fn () => exp, + decl = fn () => decl, + bind = fn _ => ()} () d + fun fold {kind, con, exp, decl} s d = case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), con = fn c => fn s => S.Continue (c, con (c, s)), diff --git a/src/demo.sml b/src/demo.sml index 1e58e2f8..ef57e65b 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -98,6 +98,10 @@ fun make' {prefix, dirname, guided} = NONE => OS.Path.joinDirFile {dir = dirname, file = "demo.sql"} | SOME s => s), + endpoints = SOME (case Settings.getEndpoints () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo-endpoints.json"} + | SOME e => e), debug = Settings.getDebug (), timeout = Int.max (#timeout combined, #timeout urp), profile = false, @@ -124,6 +128,7 @@ fun make' {prefix, dirname, guided} = dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), fileCache = mergeWith #2 (#fileCache combined, #fileCache urp), + safeGetDefault = #safeGetDefault combined orelse #safeGetDefault urp, safeGets = #safeGets combined @ #safeGets urp, onError = NONE, minHeap = 0, diff --git a/src/elab_env.sig b/src/elab_env.sig index 47b31c08..4f994221 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -100,6 +100,10 @@ signature ELAB_ENV = sig val lookupStrNamed : env -> int -> string * Elab.sgn val lookupStr : env -> string -> (int * Elab.sgn) option + + val dumpCs: env -> (string * Elab.kind) list + val dumpEs: env -> (string * Elab.con) list + val dumpStrs: env -> (string * (int * Elab.sgn)) list val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index 0474bf7c..5fa32cd2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -493,10 +493,11 @@ fun class_name_in (c, _) = case c of CNamed n => SOME (ClNamed n) | CModProj x => SOME (ClProj x) + | CAbs (_, _, c') => class_head_in c' | CUnif (_, _, _, _, ref (Known c)) => class_name_in c | _ => NONE -fun isClass (env : env) c = +and isClass (env : env) c = let fun find NONE = false | find (SOME c) = Option.isSome (CM.find (#classes env, c)) @@ -504,7 +505,7 @@ fun isClass (env : env) c = find (class_name_in c) end -fun class_head_in c = +and class_head_in c = case #1 c of CApp (f, _) => class_head_in f | CUnif (_, _, _, _, ref (Known c)) => class_head_in c @@ -985,6 +986,16 @@ fun lookupStrNamed (env : env) n = fun lookupStr (env : env) x = SM.find (#renameStr env, x) +fun dumpCs (env: env): (string * kind) list = + List.map (fn (name, value) => case value of + Rel' (_, x) => (name, x) + | Named' (_, x) => (name, x)) + (SM.listItemsi (#renameC env)) +(* TODO try again with #renameE *) +fun dumpEs (env: env): (string * con) list = + #relE env @ IM.listItems (#namedE env) +fun dumpStrs (env: env) = + SM.listItemsi (#renameStr env) fun sgiSeek (sgi, (sgns, strs, cons)) = case sgi of 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..834964ae 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) + 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,15 +79,16 @@ 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 UnboundCon (loc, s) => - ErrorMsg.errorAt loc ("Unbound constructor variable " ^ s) + ErrorMsg.errorAt loc ("Unbound constructor variable: " ^ s) | UnboundDatatype (loc, s) => - ErrorMsg.errorAt loc ("Unbound datatype " ^ s) + ErrorMsg.errorAt loc ("Unbound datatype: " ^ s) | UnboundStrInCon (loc, s) => - ErrorMsg.errorAt loc ("Unbound structure " ^ s) + ErrorMsg.errorAt loc ("Unbound structure: " ^ s) | WrongKind (c, k1, k2, env', kerr) => (ErrorMsg.errorAt (#2 c) "Wrong kind"; eprefaces' [("Constructor", p_con env c), @@ -92,7 +96,7 @@ fun conError env err = ("Need kind", p_kind env k2)]; kunifyError env' kerr) | DuplicateField (loc, s) => - ErrorMsg.errorAt loc ("Duplicate record field " ^ s) + ErrorMsg.errorAt loc ("Duplicate record field: " ^ s) | ProjBounds (c, n) => (ErrorMsg.errorAt (#2 c) "Out of bounds constructor projection"; eprefaces' [("Constructor", p_con env c), @@ -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 @@ -195,9 +201,9 @@ val p_pat = P.p_pat fun expError env err = case err of UnboundExp (loc, s) => - ErrorMsg.errorAt loc ("Unbound expression variable " ^ s) + ErrorMsg.errorAt loc ("Unbound expression variable: " ^ s) | UnboundStrInExp (loc, s) => - ErrorMsg.errorAt loc ("Unbound structure " ^ s) + ErrorMsg.errorAt loc ("Unbound structure: " ^ s) | Unify (e, c1, c2, env', uerr) => (ErrorMsg.errorAt (#2 e) "Unification failure"; eprefaces' [("Expression", p_exp env e), @@ -216,7 +222,7 @@ fun expError env err = eprefaces' [("Have", p_con env c1), ("Need", p_con env c2)]) | DuplicatePatternVariable (loc, s) => - ErrorMsg.errorAt loc ("Duplicate pattern variable " ^ s) + ErrorMsg.errorAt loc ("Duplicate pattern variable: " ^ s) | PatUnify (p, c1, c2, env', uerr) => (ErrorMsg.errorAt (#2 p) "Unification failure for pattern"; eprefaces' [("Pattern", p_pat env p), @@ -350,7 +356,7 @@ val p_sgn = P.p_sgn fun sgnError env err = case err of UnboundSgn (loc, s) => - ErrorMsg.errorAt loc ("Unbound signature variable " ^ s) + ErrorMsg.errorAt loc ("Unbound signature variable: " ^ s) | UnmatchedSgi (loc, sgi) => (ErrorMsg.errorAt loc "Unmatched signature item"; eprefaces' [("Item", p_sgn_item env sgi)]) diff --git a/src/elab_print.sig b/src/elab_print.sig index 1eb832b3..84715b9d 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -38,6 +38,7 @@ signature ELAB_PRINT = sig val p_sgn : ElabEnv.env -> Elab.sgn Print.printer val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer + val debug : bool ref end diff --git a/src/elab_print.sml b/src/elab_print.sml index 8a6a651a..637164f4 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -546,7 +546,10 @@ fun p_datatype env (x, n, xs, cons) = val env = E.pushCNamedAs env x n k NONE val env = foldl (fn (x, env) => E.pushCRel env x k) env xs in - box [string x, + box [(if !debug then + string (x ^ "_" ^ Int.toString n) + else + string x), p_list_sep (box []) (fn x => box [space, string x]) xs, space, string "=", 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/elab_util_pos.sig b/src/elab_util_pos.sig new file mode 100644 index 00000000..95d8b591 --- /dev/null +++ b/src/elab_util_pos.sig @@ -0,0 +1,66 @@ +(* Copyright (c) 2008-2010, 2012, 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. + *) + +(* This is identical to ELAB_UTIL, but keeps source spans around *) +(* Maybe these modules can be unified? *) + +signature ELAB_UTIL_POS = sig + + val mliftConInCon : (int -> Elab.con -> Elab.con) ref + + structure Decl : sig + datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + + val fold : {kind : Elab.kind * 'state -> 'state, + con : Elab.con * 'state -> 'state, + exp : Elab.exp * 'state -> 'state, + sgn_item : Elab.sgn_item * 'state -> 'state, + sgn : Elab.sgn * 'state -> 'state, + str : Elab.str * 'state -> 'state, + decl : Elab.decl * 'state -> 'state} + -> 'state -> Elab.decl -> 'state + + val foldB : {kind : 'context * Elab.kind * 'state -> 'state, + con : 'context * Elab.con * 'state -> 'state, + exp : 'context * Elab.exp * 'state -> 'state, + sgn_item : 'context * Elab.sgn_item * 'state -> 'state, + sgn : 'context * Elab.sgn * 'state -> 'state, + str : 'context * Elab.str * 'state -> 'state, + decl : 'context * Elab.decl * 'state -> 'state, + bind: 'context * binder -> 'context + } + -> 'context -> 'state -> Elab.decl -> 'state + end + +end diff --git a/src/elab_util_pos.sml b/src/elab_util_pos.sml new file mode 100644 index 00000000..d8d1bfdd --- /dev/null +++ b/src/elab_util_pos.sml @@ -0,0 +1,910 @@ +(* Copyright (c) 2008-2010, 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. + *) + +structure ElabUtilPos :> ELAB_UTIL_POS = struct + +open Elab + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindPWithPos (mfk' ctx k acc, kind ctx) + + and mfk' ctx (kAll as (k, loc)) = + case k of + KType => S.return2 kAll + + | KArrow (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (KArrow (k1', k2'), loc))) + + | KName => S.return2 kAll + + | KRecord k => + S.map2 (mfk ctx k, + fn k' => + (KRecord k', loc)) + + | KUnit => S.return2 kAll + + | KTuple ks => + S.map2 (ListUtil.mapfold (mfk ctx) ks, + fn ks' => + (KTuple ks', loc)) + + | KError => S.return2 kAll + + | KUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KUnif _ => S.return2 kAll + + | KTupleUnif (_, _, ref (KKnown k)) => mfk' ctx k + | KTupleUnif (loc, nks, r) => + S.map2 (ListUtil.mapfold (fn (n, k) => + S.map2 (mfk ctx k, + fn k' => + (n, k'))) nks, + fn nks' => + (KTupleUnif (loc, nks', r), loc)) + + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +end + +val mliftConInCon = ref (fn n : int => fn c : con => (raise Fail "You didn't set ElabUtil.mliftConInCon!") : con) + +structure Con = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)} + + fun mfc ctx c acc = + S.bindPWithPos (mfc' ctx c acc, fc ctx) + + and mfc' ctx (cAll as (c, loc)) = + case c of + TFun (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (TFun (c1', c2'), loc))) + | TCFun (e, x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (e, x, k', c'), loc))) + | TDisjoint (c1, c2, c3) => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfc ctx c2, + fn c2' => + S.map2 (mfc ctx c3, + fn c3' => + (TDisjoint (c1', c2', c3'), loc)))) + | TRecord c => + S.map2 (mfc ctx c, + fn c' => + (TRecord c', loc)) + + | CRel _ => S.return2 cAll + | CNamed _ => S.return2 cAll + | CModProj _ => S.return2 cAll + | CApp (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CApp (c1', c2'), loc))) + | CAbs (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (CAbs (x, k', c'), loc))) + + | CName _ => S.return2 cAll + + | CRecord (k, xcs) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (ListUtil.mapfold (fn (x, c) => + S.bind2 (mfc ctx x, + fn x' => + S.map2 (mfc ctx c, + fn c' => + (x', c')))) + xcs, + fn xcs' => + (CRecord (k', xcs'), loc))) + | CConcat (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (CConcat (c1', c2'), loc))) + | CMap (k1, k2) => + S.bind2 (mfk ctx k1, + fn k1' => + S.map2 (mfk ctx k2, + fn k2' => + (CMap (k1', k2'), loc))) + + | CUnit => S.return2 cAll + + | CTuple cs => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (CTuple cs', loc)) + + | CProj (c, n) => + S.map2 (mfc ctx c, + fn c' => + (CProj (c', n), loc)) + + | CError => S.return2 cAll + | CUnif (nl, _, _, _, ref (Known c)) => mfc' ctx (!mliftConInCon nl c) + | CUnif _ => S.return2 cAll + + | CKAbs (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (CKAbs (x, c'), loc)) + | CKApp (c, k) => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfk ctx k, + fn k' => + (CKApp (c', k'), loc))) + | TKFun (x, c) => + S.map2 (mfc (bind (ctx, RelK x)) c, + fn c' => + (TKFun (x, c'), loc)) + in + mfc + end + +end + +structure Exp = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + +fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun doVars ((p, _), ctx) = + case p of + PVar xt => bind (ctx, RelE xt) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => doVars (p, ctx) + | PRecord xpcs => + foldl (fn ((_, p, _), ctx) => doVars (p, ctx)) + ctx xpcs + + fun mfe ctx e acc = + S.bindPWithPos (mfe' ctx e acc, fe ctx) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | EModProj _ => S.return2 eAll + | EApp (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EApp (e1', e2'), loc))) + | EAbs (x, dom, ran, e) => + S.bind2 (mfc ctx dom, + fn dom' => + S.bind2 (mfc ctx ran, + fn ran' => + S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, + fn e' => + (EAbs (x, dom', ran', e'), loc)))) + + | ECApp (e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (ECApp (e', c'), loc))) + | ECAbs (expl, x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (expl, x, k', e'), loc))) + + | ERecord xes => + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfc ctx x, + fn x' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (x', e', t'))))) + xes, + fn xes' => + (ERecord xes', loc)) + | EField (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (EField (e', c', {field = field', rest = rest'}), loc))))) + | EConcat (e1, c1, e2, c2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.bind2 (mfc ctx c1, + fn c1' => + S.bind2 (mfe ctx e2, + fn e2' => + S.map2 (mfc ctx c2, + fn c2' => + (EConcat (e1', c1', e2', c2'), + loc))))) + | ECut (e, c, {field, rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfc ctx field, + fn field' => + S.map2 (mfc ctx rest, + fn rest' => + (ECut (e', c', {field = field', rest = rest'}), loc))))) + + | ECutMulti (e, c, {rest}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfc ctx rest, + fn rest' => + (ECutMulti (e', c', {rest = rest'}), loc)))) + + | ECase (e, pes, {disc, result}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (ListUtil.mapfold (fn (p, e) => + let + fun pb ((p, _), ctx) = + case p of + PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfe (pb (p', ctx)) e, + fn e' => (p', e'))) + end) pes, + fn pes' => + S.bind2 (mfc ctx disc, + fn disc' => + S.map2 (mfc ctx result, + fn result' => + (ECase (e', pes', {disc = disc', result = result'}), loc))))) + + | EError => S.return2 eAll + | EUnif (ref (SOME e)) => mfe ctx e + | EUnif _ => S.return2 eAll + + | ELet (des, e, t) => + let + val (des, ctx') = foldl (fn (ed, (des, ctx)) => + let + val ctx' = + case #1 ed of + EDVal (p, _, _) => doVars (p, ctx) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) + ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => ed' :: des')), + ctx') + end) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.bind2 (mfe ctx' e, + fn e' => + S.map2 (mfc ctx t, + fn t' => + (ELet (rev des', e', t'), loc)))) + end + + | EKAbs (x, e) => + S.map2 (mfe (bind (ctx, RelK x)) e, + fn e' => + (EKAbs (x, e'), loc)) + | EKApp (e, k) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfk ctx k, + fn k' => + (EKApp (e', k'), loc))) + + and mfp ctx (pAll as (p, loc)) = + case p of + PVar (x, t) => + S.map2 (mfc ctx t, + fn t' => + (PVar (x, t'), loc)) + | PPrim _ => S.return2 pAll + | PCon (dk, pc, args, po) => + S.bind2 (ListUtil.mapfold (mfc ctx) args, + fn args' => + S.map2 ((case po of + NONE => S.return2 NONE + | SOME p => S.map2 (mfp ctx p, SOME)), + fn po' => + (PCon (dk, pc, args', po'), loc))) + | PRecord xps => + S.map2 (ListUtil.mapfold (fn (x, p, c) => + S.bind2 (mfp ctx p, + fn p' => + S.map2 (mfc ctx c, + fn c' => + (x, p', c')))) xps, + fn xps' => + (PRecord xps', loc)) + + 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))) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) + in + mfe + end + +end + +structure Sgn = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind, con, sgn_item, sgn, bind} = + let + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val con = Con.mapfoldB {kind = kind, con = con, bind = bind'} + + val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun sgi ctx si acc = + S.bindPWithPos (sgi' ctx si acc, sgn_item ctx) + + and sgi' ctx (siAll as (si, loc)) = + case si of + SgiConAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiConAbs (x, n, k'), loc)) + | SgiCon (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiCon (x, n, k', c'), loc))) + | SgiDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xs, xncs'))) dts, + fn dts' => + (SgiDatatype dts', loc)) + | SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (con ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (SgiDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | SgiVal (x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiVal (x, n, c'), loc)) + | SgiStr (im, x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiStr (im, x, n, s'), loc)) + | SgiSgn (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiSgn (x, n, s'), loc)) + | SgiConstraint (c1, c2) => + S.bind2 (con ctx c1, + fn c1' => + S.map2 (con ctx c2, + fn c2' => + (SgiConstraint (c1', c2'), loc))) + | SgiClassAbs (x, n, k) => + S.map2 (kind ctx k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind ctx k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) + + and sg ctx s acc = + S.bindPWithPos (sg' ctx s acc, sgn ctx) + + and sg' ctx (sAll as (s, loc)) = + case s of + SgnConst sgis => + S.map2 (ListUtil.mapfoldB (fn (ctx, si) => + (case #1 si of + SgiConAbs (x, n, k) => + bind (ctx, NamedC (x, n, k, NONE)) + | SgiCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | SgiDatatype dts => + foldl (fn ((x, n, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, n, k, NONE)) + end) ctx dts + | SgiDatatypeImp (x, n, m1, ms, s, _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m1, ms, s), loc))) + | SgiVal _ => ctx + | SgiStr (_, x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | SgiSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | SgiConstraint _ => ctx + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), NONE)) + | SgiClass (x, n, k, c) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc), SOME c)), + sgi ctx si)) ctx sgis, + fn sgis' => + (SgnConst sgis', loc)) + + | SgnVar _ => S.return2 sAll + | SgnFun (m, n, s1, s2) => + S.bind2 (sg ctx s1, + fn s1' => + S.map2 (sg (bind (ctx, Str (m, n, s1'))) s2, + fn s2' => + (SgnFun (m, n, s1', s2'), loc))) + | SgnProj _ => S.return2 sAll + | SgnWhere (sgn, ms, x, c) => + S.bind2 (sg ctx sgn, + fn sgn' => + S.map2 (con ctx c, + fn c' => + (SgnWhere (sgn', ms, x, c'), loc))) + | SgnError => S.return2 sAll + in + sg + end + +end + +structure Decl = struct + +datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + | RelE of string * Elab.con + | NamedE of string * Elab.con + | Str of string * int * Elab.sgn + | Sgn of string * int * Elab.sgn + +fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun bind' (ctx, b) = + let + val b' = case b of + Con.RelK x => RelK x + | Con.RelC x => RelC x + | Con.NamedC x => NamedC x + in + bind (ctx, b') + end + val mfc = Con.mapfoldB {kind = fk, con = fc, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Exp.RelK x => RelK x + | Exp.RelC x => RelC x + | Exp.NamedC x => NamedC x + | Exp.RelE x => RelE x + | Exp.NamedE x => NamedE x + in + bind (ctx, b') + end + val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind'} + + fun bind' (ctx, b) = + let + val b' = case b of + Sgn.RelK x => RelK x + | Sgn.RelC x => RelC x + | Sgn.NamedC x => NamedC x + | Sgn.Sgn x => Sgn x + | Sgn.Str x => Str x + in + bind (ctx, b') + end + val mfsg = Sgn.mapfoldB {kind = fk, con = fc, sgn_item = fsgi, sgn = fsg, bind = bind'} + + fun mfst ctx str acc = + S.bindPWithPos (mfst' ctx str acc, fst ctx) + + and mfst' ctx (strAll as (str, loc)) = + case str of + StrConst ds => + S.map2 (ListUtil.mapfoldB (fn (ctx, d) => + (case #1 d of + DCon (x, n, k, c) => + bind (ctx, NamedC (x, n, k, SOME c)) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), ctx) = + let + val ctx = bind (ctx, NamedC (x, n, (KType, loc), NONE)) + in + foldl (fn ((x, _, co), ctx) => + let + val t = + case co of + NONE => CNamed n + | SOME t => TFun (t, (CNamed n, loc)) + + val k = (KType, loc) + val t = (t, loc) + val t = foldr (fn (x, t) => + (TCFun (Explicit, + x, + k, + t), loc)) + t xs + in + bind (ctx, NamedE (x, t)) + end) + ctx xncs + end + in + foldl doOne ctx dts + end + | DDatatypeImp (x, n, m, ms, x', _, _) => + bind (ctx, NamedC (x, n, (KType, loc), + SOME (CModProj (m, ms, x'), loc))) + | DVal (x, _, c, _) => + bind (ctx, NamedE (x, c)) + | DValRec vis => + foldl (fn ((x, _, c, _), ctx) => bind (ctx, NamedE (x, c))) ctx vis + | DSgn (x, n, sgn) => + bind (ctx, Sgn (x, n, sgn)) + | DStr (x, n, sgn, _) => + bind (ctx, Str (x, n, sgn)) + | DFfiStr (x, n, sgn) => + bind (ctx, Str (x, n, sgn)) + | DConstraint _ => ctx + | DExport _ => ctx + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (n, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DSequence (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) + | DTask _ => ctx + | DPolicy _ => ctx + | DOnError _ => ctx + | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)), + mfd ctx d)) ctx ds, + fn ds' => (StrConst ds', loc)) + | StrVar _ => S.return2 strAll + | StrProj (str, x) => + S.map2 (mfst ctx str, + fn str' => + (StrProj (str', x), loc)) + | StrFun (x, n, sgn1, sgn2, str) => + S.bind2 (mfsg ctx sgn1, + fn sgn1' => + S.bind2 (mfsg ctx sgn2, + fn sgn2' => + S.map2 (mfst ctx str, + fn str' => + (StrFun (x, n, sgn1', sgn2', str'), loc)))) + | StrApp (str1, str2) => + S.bind2 (mfst ctx str1, + fn str1' => + S.map2 (mfst ctx str2, + fn str2' => + (StrApp (str1', str2'), loc))) + | StrError => S.return2 strAll + + and mfd ctx d acc = + S.bindPWithPos (mfd' ctx d acc, fd ctx) + + and mfd' ctx (dAll as (d, loc)) = + case d of + DCon (x, n, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DCon (x, n, k', c'), loc))) + | DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (x, n, xs, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) + | DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mfc ctx c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => + (DDatatypeImp (x, n, m1, ms, s, xs, xncs'), loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (DValRec vis', loc)) + | DSgn (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DSgn (x, n, sgn'), loc)) + | DStr (x, n, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DStr (x, n, sgn', str'), loc))) + | DFfiStr (x, n, sgn) => + S.map2 (mfsg ctx sgn, + fn sgn' => + (DFfiStr (x, n, sgn'), loc)) + | DConstraint (c1, c2) => + S.bind2 (mfc ctx c1, + fn c1' => + S.map2 (mfc ctx c2, + fn c2' => + (DConstraint (c1', c2'), loc))) + | DExport (en, sgn, str) => + S.bind2 (mfsg ctx sgn, + fn sgn' => + S.map2 (mfst ctx str, + fn str' => + (DExport (en, sgn', str'), loc))) + + | DTable (tn, x, n, c, pe, pc, ce, cc) => + S.bind2 (mfc ctx c, + fn c' => + S.bind2 (mfe ctx pe, + fn pe' => + S.bind2 (mfc ctx pc, + fn pc' => + S.bind2 (mfe ctx ce, + fn ce' => + S.map2 (mfc ctx cc, + fn cc' => + (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) + | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) + + | DDatabase _ => S.return2 dAll + + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll + | DTask (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (DTask (e1', e2'), loc))) + | DPolicy e1 => + S.map2 (mfe ctx e1, + fn e1' => + (DPolicy e1', loc)) + | DOnError _ => S.return2 dAll + | DFfi (x, n, modes, t) => + S.map2 (mfc ctx t, + fn t' => + (DFfi (x, n, modes, t'), loc)) + + and mfvi ctx (x, n, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, n, c', e'))) + in + mfd + end + + fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a = + case mapfoldB {kind = fn () => fn k => fn st => S.Continue (#1 k, kind (k, st)), + con = fn () => fn c => fn st => S.Continue (#1 c, con (c, st)), + exp = fn () => fn e => fn st => S.Continue (#1 e, exp (e, st)), + sgn_item = fn () => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (sgi, st)), + sgn = fn () => fn s => fn st => S.Continue (#1 s, sgn (s, st)), + str = fn () => fn str' => fn st => S.Continue (#1 str', str (str', st)), + decl = fn () => fn d => fn st => S.Continue (#1 d, decl (d, st)), + bind = fn ((), _) => () + } () d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible" + + fun foldB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx (st : 'a) d : 'a = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (#1 k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (#1 c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (#1 e, exp (ctx, e, st)), + sgn_item = fn ctx => fn sgi => fn st => S.Continue (#1 sgi, sgn_item (ctx, sgi, st)), + sgn = fn ctx => fn s => fn st => S.Continue (#1 s, sgn (ctx, s, st)), + str = fn ctx => fn str' => fn st => S.Continue (#1 str', str (ctx, str', st)), + decl = fn ctx => fn d => fn st => S.Continue (#1 d, decl (ctx, d, st)), + bind = bind + } ctx d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.foldB: Impossible" + end +end diff --git a/src/elaborate.sig b/src/elaborate.sig index d60cff42..d6747241 100644 --- a/src/elaborate.sig +++ b/src/elaborate.sig @@ -29,7 +29,10 @@ signature ELABORATE = sig val elabFile : Source.sgn_item list -> Time.time -> Source.decl list -> Source.sgn_item list -> Time.time - -> ElabEnv.env -> Source.file -> Elab.file + -> ElabEnv.env + -> (ElabEnv.env -> ElabEnv.env) (* Adapt env after stdlib but before elaborate *) + -> Source.file + -> Elab.file val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option @@ -47,4 +50,24 @@ signature ELABORATE = sig val incremental : bool ref val verbose : bool ref + val dopen: ElabEnv.env + -> { str: int + , strs: string list + , sgn: Elab.sgn } + -> (Elab.decl list * ElabEnv.env) + + val elabSgn: (ElabEnv.env * Disjoint.env) + -> Source.sgn + -> (Elab.sgn * Disjoint.goal list) + + datatype constraint = + Disjoint of Disjoint.goal + | TypeClass of ElabEnv.env * Elab.con * Elab.exp option ref * ErrorMsg.span + + val elabStr: (ElabEnv.env * Disjoint.env) + -> Source.str + -> (Elab.str * Elab.sgn * constraint list) + + val subSgn: ElabEnv.env -> ErrorMsg.span -> Elab.sgn -> Elab.sgn -> unit + end diff --git a/src/elaborate.sml b/src/elaborate.sml index 51d00bd8..e975cabe 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''' @@ -2800,7 +2822,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end) -and elabSgn (env, denv) (sgn, loc) = +and elabSgn (env, denv) (sgn, loc): (L'.sgn * D.goal list) = case sgn of L.SgnConst sgis => let @@ -3284,12 +3306,33 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = SOME env end - val env = E.pushCNamedAs env x1 n1 k' NONE - val env = if n1 = n2 then - env - else - (cparts (n2, n1); - E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) + fun dt_pusher (dts1, dts2, env) = + case (dts1, dts2) of + ((x1, n1, xs1, _) :: dts1', (x2, n2, xs2, _) :: dts2') => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 + + val env = E.pushCNamedAs env x1 n1 k' NONE + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) + in + dt_pusher (dts1', dts2', env) + end + | _ => env + val env = case #1 sgi1All of + L'.SgiDatatype dts1 => dt_pusher (dts1, dts2, env) + | _ => foldl (fn ((x2, n2, xs2, _), env) => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs2 + in + E.pushCNamedAs env x2 n2 k' NONE + end) env dts2 + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 fun xncBad ((x1, _, t1), (x2, _, t2)) = String.compare (x1, x2) <> EQUAL @@ -4131,7 +4174,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)) @@ -4150,13 +4193,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | NONE => let val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else () + val () = ErrorMsg.startElabStructure x val () = if x = "Basis" then raise Fail "Not allowed to redefine structure 'Basis'" 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 @@ -4191,7 +4235,10 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = L'.StrFun _ => () | _ => strError env (FunctorRebind loc)) | _ => (); - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.app (fn tm => ModDb.insert (dNew, + tm, + ErrorMsg.stopElabStructureAndGetErrored x + )) tmo; ([dNew], (env', denv', gs' @ gs)) end) @@ -4206,7 +4253,9 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = end | NONE => let - val (sgn', gs') = elabSgn (env, denv) sgn + val () = ErrorMsg.startElabStructure x + + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushStrNamed env x sgn' @@ -4224,7 +4273,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = epreface ("item", p_sgn_item env sgi))) | _ => raise Fail "FFI signature isn't SgnConst"; - Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + Option.map (fn tm => ModDb.insert (dNew, tm, ErrorMsg.stopElabStructureAndGetErrored x)) tmo; ([dNew], (env', denv, enD gs' @ gs)) end) @@ -4717,13 +4766,16 @@ and elabStr (env, denv) (str, loc) = fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env -fun elabFile basis basis_tm topStr topSgn top_tm env file = +fun elabFile basis basis_tm topStr topSgn top_tm env changeEnv file = let val () = ModDb.snapshot () + val () = ErrorMsg.resetStructureTracker () + 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) = @@ -4741,7 +4793,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', basis_n) = E.pushStrNamed env "Basis" sgn in - ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm); + ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm, false); (* TODO: also check for errors? *) (basis_n, env', sgn) end | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) => @@ -4800,7 +4852,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (env', top_n) = E.pushStrNamed env' "Top" topSgn in - ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm); + ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm, false); (* TODO: also check for errors? *) (top_n, env', topSgn, topStr) end | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) => @@ -4811,6 +4863,8 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + val env' = changeEnv env' + fun elabDecl' x = (resetKunif (); resetCunif (); @@ -5083,11 +5137,6 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = else (); - if ErrorMsg.anyErrors () then - ModDb.revert () - else - (); - (*Print.preface("File", ElabPrint.p_file env file);*) (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) diff --git a/src/elisp/urweb-flycheck.el b/src/elisp/urweb-flycheck.el new file mode 100644 index 00000000..31433fbc --- /dev/null +++ b/src/elisp/urweb-flycheck.el @@ -0,0 +1,100 @@ +;;; urweb-flycheck.el --- Flycheck: Ur/Web support -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Artyom Shalkhakov <artyom.shalkhakov@gmail.com> + +;; Author: +;; Artyom Shalkhakov <artyom.shalkhakov@gmail.com> +;; David Christiansen <david@davidchristiansen.dk> +;; +;; Keywords: tools, languages, convenience +;; Version: 0.2 +;; Package-Requires: ((emacs "24.1") (flycheck "0.22")) + +;; This file is not part of GNU Emacs, but it is distributed under the +;; same conditions. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This Flycheck extension provides an 'urweb' syntax checker. +;; +;; # Setup +;; +;; Put the following into your 'init' file: +;; +;; (with-eval-after-load 'flycheck (urweb-flycheck-setup)) +;; +;; Ensure that the Ur/Web compiler is in your PATH +;; + +;;; Code: + +(require 'flycheck) + +(defun urweb-get-flycheck-project-file () + "Guess the location of the nearest urp file." + (let ((bn (buffer-file-name))) + (if bn + (let + ((x (file-name-sans-extension bn)) + (y (file-name-directory bn))) + (cond + ;; file with .urp extension exists? take it + ((file-exists-p (concat x ".urp")) x) + ;; lib.urp exists in this directory? take it + ((file-exists-p (concat y "/lib.urp")) (concat y "/lib")) + ;; fall back to the first .urp file in this directory + ;; or if that fails, use the current file name + (t (or (car (directory-files y nil "\\.urp$")) x))))))) + +(flycheck-define-checker urweb + "Ur/Web checker" + :command ("urweb" "-tc" + (eval (urweb-get-flycheck-project-file))) + ;; filename:1:0: (to 1:0) syntax error found at SYMBOL + ;; filename:1:0: (to 1:38) Some constructor unification variables are undetermined in declaration + ;; (look for them as "<UNIF:...>") + ;; Decl: + ;; val rec + ;; help : + ;; {} -> <UNIF:E::Type -> Type> (xml <UNIF:G::{Unit}> <UNIF:H::{Type}> ([])) = + ;; fn $x : {} => + ;; case $x of + ;; {} => + ;; return [<UNIF:E::Type -> Type>] + ;; [xml <UNIF:G::{Unit}> <UNIF:H::{Type}> ([])] _ + ;; (Basis.cdata [<UNIF:G::{Unit}>] [<UNIF:H::{Type}>] "Hello!") + + :error-patterns + ((error line-start (file-name) ":" line ":" column ":" + " (to " (1+ num) ?: (1+ num) ")" + ;; AS: indebted to David Christiansen for this rx expression! + (message (and (* nonl) (* "\n" (not (any "/" "~")) (* nonl)))))) + :predicate + (lambda () + (buffer-file-name)) + :modes (urweb-mode)) + +;;;###autoload +(defun urweb-flycheck-setup () + "Setup Flycheck Ur/Web. + +Add `urweb' to `flycheck-checkers'." + (interactive) + (add-to-list 'flycheck-checkers 'urweb)) + +(provide 'urweb-flycheck) +;;; urweb-flycheck.el ends here diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 69b0e23c..057761ac 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -925,6 +925,33 @@ Optional argument STYLE is currently ignored." (urweb-skip-siblings)) fullname))) +(defun urweb-get-proj-dir (bfn) + (locate-dominating-file + bfn + (lambda (dir) + (some (lambda (f) (s-suffix? ".urp" f)) + (if (f-dir? dir) + (directory-files dir) + (list '(dir))))))) + +(defun urweb-get-info () + (interactive) + (let* + ((row (line-number-at-pos)) + (col (evil-column)) + (bfn (buffer-file-name)) + (proj-dir (urweb-get-proj-dir bfn)) + (filename (file-relative-name bfn proj-dir)) + (loc (concat filename ":" (number-to-string row) ":" (number-to-string col))) + ) + (require 's) + (require 'f) + (require 'simple) + (message (let + ((default-directory proj-dir)) + (shell-command-to-string (concat "urweb -getInfo " loc))))) + ) + (provide 'urweb-mode) ;;; urweb-mode.el ends here diff --git a/src/endpoints.sig b/src/endpoints.sig new file mode 100644 index 00000000..89e72add --- /dev/null +++ b/src/endpoints.sig @@ -0,0 +1,44 @@ +(* Copyright (c) 2019, Artyom Shalkhakov + * 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. + *) + +signature ENDPOINTS = sig + + datatype method = GET | POST + val methodToString : method -> string + + type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option} + val p_endpoint : endpoint Print.printer + + type report = {Endpoints : endpoint list} + val p_report : report Print.printer + + val reset : unit -> unit + val collect : Mono.file -> Mono.file + val setJavaScript : string -> unit + val summarize : unit -> report + +end diff --git a/src/endpoints.sml b/src/endpoints.sml new file mode 100644 index 00000000..5699f319 --- /dev/null +++ b/src/endpoints.sml @@ -0,0 +1,117 @@ +(* Copyright (c) 2019 Artyom Shalkhakov + * 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. + *) + +structure Endpoints :> ENDPOINTS = struct + +open Print.PD +open Print + +open Mono + +datatype method = GET | POST + +fun methodToString GET = "GET" + | methodToString POST = "POST" + +type endpoint = {Method : method, Url : string, ContentType : string option, LastModified : Time.time option} +type report = {Endpoints : endpoint list} + +fun p_endpoint {Method = m, Url = u, ContentType = oct, LastModified = olm} = + let + val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT" + in + box [string "{", + string "\"method\": \"", string (methodToString m), string "\", ", + string "\"url\": \"", string u, string "\", ", + string "\"content-type\": ", (case oct of SOME ct => box [string "\"", string ct, string"\""] + | NONE => string "null"), + string "}"] + end + +fun p_report {Endpoints = el} = + box [string "{\"endpoints\":", + space, + string "[", + p_list_sep (box [string ",", newline]) p_endpoint el, + string "]}"] + +val endpoints = ref ([] : endpoint list) +val jsFile = ref (NONE : string option) + +fun setJavaScript x = jsFile := SOME x + +fun reset () = (endpoints := []; jsFile := NONE) + +fun collect file = + let + fun exportKindToMethod (Link _) = GET + | exportKindToMethod (Action _) = POST + | exportKindToMethod (Rpc _) = POST + | exportKindToMethod (Extern _) = POST + + fun decl ((d, _), st as endpoints) = + let + in + case d of + DExport (ek, id, i, tl, rt, f) => + {Method = exportKindToMethod ek, Url = id, LastModified = NONE, ContentType = NONE} :: st + | _ => st + end + + val () = reset () + + val (decls, _) = file + val ep = foldl decl [] decls + + fun binfile ({Uri = u, ContentType = ct, LastModified = lm, Bytes = _ }, st) = + {Method = GET, Url = u, LastModified = SOME lm, ContentType = ct} :: st + + val ep = foldl binfile ep (Settings.listFiles ()) + + fun jsfile ({Filename = f, Content = _}, st) = + {Method = GET, Url = f, LastModified = NONE, ContentType = SOME "text/javascript"} :: st + + val ep = foldl jsfile ep (Settings.listJsFiles ()) + in + endpoints := ep; + file + end + +fun summarize () = + let + val ep = !endpoints + val js = !jsFile + val ep = + case js of + NONE => ep + | SOME js => + {Method = GET, Url = js, LastModified = NONE, ContentType = SOME "text/javascript"} :: ep + in + {Endpoints = ep} + end + +end diff --git a/src/errormsg.sig b/src/errormsg.sig index 92425842..1fa4013c 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -48,9 +48,17 @@ signature ERROR_MSG = sig val posOf : int -> pos val spanOf : int * int -> span + (* To monitor in which modules the elaboration phase finds errors *) + val startElabStructure : string -> unit + val stopElabStructureAndGetErrored : string -> bool (* Did the module elab encounter errors? *) + + val resetStructureTracker: unit -> unit val resetErrors : unit -> unit val anyErrors : unit -> bool val error : string -> unit val errorAt : span -> string -> unit val errorAt' : int * int -> string -> unit + val readErrorLog: unit -> + { span: span + , message: string } list end diff --git a/src/errormsg.sml b/src/errormsg.sml index 8f3c93b1..d40789ed 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -88,12 +88,34 @@ fun spanOf (pos1, pos2) = {file = !file, val errors = ref false +val errorLog = ref ([]: { span: span + , message: string } list) +fun readErrorLog () = !errorLog +val structuresCurrentlyElaborating: ((string * bool) list) ref = ref nil + +fun startElabStructure s = + structuresCurrentlyElaborating := ((s, false) :: !structuresCurrentlyElaborating) +fun stopElabStructureAndGetErrored s = + let + val errored = + case List.find (fn x => #1 x = s) (!structuresCurrentlyElaborating) of + NONE => false + | SOME tup => #2 tup + val () = structuresCurrentlyElaborating := + (List.filter (fn x => #1 x <> s) (!structuresCurrentlyElaborating)) + in + errored + end +fun resetStructureTracker () = + structuresCurrentlyElaborating := [] -fun resetErrors () = errors := false +fun resetErrors () = (errors := false; errorLog := []) fun anyErrors () = !errors fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); - errors := true) + errors := true; + structuresCurrentlyElaborating := + List.map (fn (s, e) => (s, true)) (!structuresCurrentlyElaborating)) fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ":"); @@ -101,6 +123,9 @@ fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); TextIO.output (TextIO.stdErr, ": (to "); TextIO.output (TextIO.stdErr, posToString (#last span)); TextIO.output (TextIO.stdErr, ") "); + errorLog := ({ span = span + , message = s + } :: !errorLog); error s) fun errorAt' span s = errorAt (spanOf span) s diff --git a/src/filecache.sml b/src/filecache.sml index e2291c10..a0da4b05 100644 --- a/src/filecache.sml +++ b/src/filecache.sml @@ -81,7 +81,10 @@ fun instrument file = fun wrapCol (name, t) = case #1 t of TFfi ("Basis", "blob") => - "DIGEST(" ^ name ^ ", 'sha512')" + (case #supportsSHA512 (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "DBMS doesn't support SHA512."; + "ERROR") + | SOME r => #GenerateHash r name) | TOption t' => wrapCol (name, t') | _ => name diff --git a/src/fromjson.sig b/src/fromjson.sig new file mode 100644 index 00000000..3fdc1a89 --- /dev/null +++ b/src/fromjson.sig @@ -0,0 +1,8 @@ +signature FROMJSON = sig + val getO: string -> Json.json -> Json.json option + val get: string -> Json.json -> Json.json + val asInt: Json.json -> int + val asString: Json.json -> string + val asOptionalInt: Json.json -> int option + val asOptionalString: Json.json -> string option +end diff --git a/src/fromjson.sml b/src/fromjson.sml new file mode 100644 index 00000000..6a9bd71b --- /dev/null +++ b/src/fromjson.sml @@ -0,0 +1,35 @@ +structure FromJson :> FROMJSON = struct +fun getO (s: string) (l: Json.json): Json.json option = + case l of + Json.Obj pairs => + (case List.find (fn tup => #1 tup = s) pairs of + NONE => NONE + | SOME tup => SOME (#2 tup)) + | _ => raise Fail ("Expected JSON object, got: " ^ Json.print l) +fun get (s: string) (l: Json.json): Json.json = + (case getO s l of + NONE => raise Fail ("Failed to find JSON object key " ^ s ^ " in " ^ Json.print l) + | SOME a => a) + +fun asInt (j: Json.json): int = + case j of + Json.Int i => i + | _ => raise Fail ("Expected JSON int, got: " ^ Json.print j) + +fun asString (j: Json.json): string = + case j of + Json.String s => s + | _ => raise Fail ("Expected JSON string, got: " ^ Json.print j) + +fun asOptionalInt (j: Json.json): int option = + case j of + Json.Null => NONE + | Json.Int i => SOME i + | _ => raise Fail ("Expected JSON int or null, got: " ^ Json.print j) + +fun asOptionalString (j: Json.json): string option = + case j of + Json.Null => NONE + | Json.String s => SOME s + | _ => raise Fail ("Expected JSON string or null, got: " ^ Json.print j) +end diff --git a/src/getinfo.sig b/src/getinfo.sig new file mode 100644 index 00000000..63850ef2 --- /dev/null +++ b/src/getinfo.sig @@ -0,0 +1,50 @@ +(* Copyright (c) 2012, 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. + *) + +signature GET_INFO = sig + + datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) + + val findStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv option) + + val matchStringInEnv: + ElabEnv.env -> + Elab.str' -> + string (* fileName *) -> + {line: int, char: int} -> + string (* query *) -> + (ElabEnv.env * string (* prefix *) * foundInEnv list) +end + diff --git a/src/getinfo.sml b/src/getinfo.sml new file mode 100644 index 00000000..2b27b8df --- /dev/null +++ b/src/getinfo.sml @@ -0,0 +1,304 @@ +(* Copyright (c) 2012, 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. + *) + +structure GetInfo :> GET_INFO = struct + +structure U = ElabUtilPos +structure E = ElabEnv +structure L = Elab + +fun isPosIn (file: string) (line: int) (char: int) (span: ErrorMsg.span) = + let + val start = #first span + val end_ = #last span + in + OS.Path.base file = OS.Path.base (#file span) + andalso + (#line start < line orelse + #line start = line andalso #char start <= char) + andalso + (#line end_ > line orelse + #line end_ = line andalso #char end_ >= char) + end + +fun isSmallerThan (s1: ErrorMsg.span) (s2: ErrorMsg.span) = + (#line (#first s1) > #line (#first s2) orelse + (#line (#first s1) = #line (#first s2) andalso (#char (#first s1) >= #char (#first s2)))) + andalso + (#line (#last s1) < #line (#last s2) orelse + (#line (#last s1) = #line (#last s2) andalso (#char (#last s1) <= #char (#last s2)))) + +datatype item = + Kind of L.kind + | Con of L.con + | Exp of L.exp + | Sgn_item of L.sgn_item + | Sgn of L.sgn + | Str of L.str + | Decl of L.decl + +fun getSpan (f: item) = + case f of + Kind k => #2 k + | Con c => #2 c + | Exp e => #2 e + | Sgn_item si => #2 si + | Sgn s => #2 s + | Str s => #2 s + | Decl d => #2 d + + +fun findInStr (f: ElabEnv.env -> item (* curr *) -> item (* prev *) -> bool) + (init: item) + env str fileName {line = line, char = char}: {item: item, env: ElabEnv.env} = + let + val () = U.mliftConInCon := E.mliftConInCon + val {env: ElabEnv.env, found: Elab.decl option} = + (case str of + L.StrConst decls => + List.foldl (fn (d, acc as {env, found}) => + if #line (#last (#2 d)) < line + then {env = E.declBinds env d, found = found} + else + if #line (#first (#2 d)) <= line andalso line <= #line (#last (#2 d)) + then {env = env, found = SOME d} + else {env = env, found = found}) + {env = env, found = NONE} decls + | _ => { env = env, found = NONE }) + val dummyResult = (init, env) + val result = + case found of + NONE => dummyResult + | SOME d => + U.Decl.foldB + { kind = fn (env, i, acc as (prev, env')) => if f env (Kind i) prev then (Kind i, env) else acc, + con = fn (env, i, acc as (prev, env')) => if f env (Con i) prev then (Con i, env) else acc, + exp = fn (env, i, acc as (prev, env')) => if f env (Exp i) prev then (Exp i, env) else acc, + sgn_item = fn (env, i, acc as (prev, env')) => if f env (Sgn_item i) prev then (Sgn_item i, env) else acc, + sgn = fn (env, i, acc as (prev, env')) => if f env (Sgn i) prev then (Sgn i, env) else acc, + str = fn (env, i, acc as (prev, env')) => if f env (Str i) prev then (Str i, env) else acc, + decl = fn (env, i, acc as (prev, env')) => if f env (Decl i) prev then (Decl i, env) else acc, + bind = fn (env, binder) => + case binder of + U.Decl.RelK x => E.pushKRel env x + | U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co + | U.Decl.RelE (x, c) => E.pushERel env x c + | U.Decl.NamedE (x, c) => #1 (E.pushENamed env x c) + | U.Decl.Str (x, n, sgn) => #1 (E.pushStrNamed env x sgn) + | U.Decl.Sgn (x, n, sgn) => #1 (E.pushSgnNamed env x sgn) + } + env dummyResult d + in + {item = #1 result, env = #2 result} + end + +fun findClosestSpan env str fileName {line = line, char = char} = + let + fun getDistance (i: item): int = + let + val {first, last, file} = getSpan i + in + Int.abs (#char first - char) + + Int.abs (#char last - char) + + Int.abs (#line first - line) * 25 + + Int.abs (#line last - line) * 25 + end + fun isCloser (env: ElabEnv.env) (curr: item) (prev: item) = + getDistance curr < getDistance prev + val init = Str (str, { file = fileName + , first = { line = 0, char = 0} + , last = { line = 0, char = 0} }) + in + findInStr isCloser init env str fileName {line = line, char = char} + end + +fun findFirstExpAfter env str fileName {line = line, char = char} = + let + fun currIsAfterPosAndBeforePrev (env: ElabEnv.env) (curr: item) (prev: item) = + (* curr is an exp *) + (case curr of Exp _ => true | _ => false) + andalso + (* curr is after input pos *) + ( line < #line (#first (getSpan curr)) + orelse ( line = #line (#first (getSpan curr)) + andalso char < #char (#first (getSpan curr)))) + andalso + (* curr is before prev *) + (#line (#first (getSpan curr)) < #line (#first (getSpan prev)) + orelse + (#line (#first (getSpan curr)) = #line (#first (getSpan prev)) + andalso #char (#first (getSpan curr)) < #char (#first (getSpan prev)))) + val init = Exp (Elab.EPrim (Prim.Int 0), + { file = fileName + , first = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} + , last = { line = Option.getOpt (Int.maxInt, 99999), char = Option.getOpt (Int.maxInt, 99999)} }) + in + findInStr currIsAfterPosAndBeforePrev init env str fileName {line = line, char = char} + end + + +datatype foundInEnv = FoundStr of (string * Elab.sgn) + | FoundKind of (string * Elab.kind) + | FoundCon of (string * Elab.con) + +fun getNameOfFoundInEnv (f: foundInEnv) = + case f of + FoundStr (x, _) => x + | FoundKind (x, _) => x + | FoundCon (x, _) => x + +fun filterSgiItems (items: Elab.sgn_item list) : foundInEnv list = + let + fun processDatatype loc (dtx, i, ks, cs) = + let + val k' = (Elab.KType, loc) + val k = FoundKind (dtx, foldl (fn (_, k) => (Elab.KArrow (k', k), loc)) k' ks) + val foundCs = List.map (fn (x, j, co) => + let + val c = case co of + NONE => (Elab.CNamed i, loc) + | SOME c => (Elab.TFun (c, (Elab.CNamed i, loc)), loc) + in + FoundCon (x, c) + end) cs + in + k :: foundCs + end + fun mapF item = + case item of + (Elab.SgiVal (name, _, c), _) => [FoundCon (name, c)] + | (Elab.SgiCon (name, _, k, _), _) => [FoundKind (name, k)] + | (Elab.SgiDatatype ds, loc) => + List.concat (List.map (processDatatype loc) ds) + | (Elab.SgiDatatypeImp (dtx, i, _, ks, _, _, cs), loc) => processDatatype loc (dtx, i, ks, cs) + | (Elab.SgiStr (_, name, _, sgn), _) => + [FoundStr (name, sgn)] + | (Elab.SgiSgn (name, _, sgn), _) => [] + | _ => [] + in + List.concat (List.map mapF items) + end + +fun resolvePrefixes + (env: ElabEnv.env) + (prefixes: string list) + (items : foundInEnv list) + : foundInEnv list + = + case prefixes of + [] => items + | first :: rest => + (case List.find (fn item => getNameOfFoundInEnv item = first) items of + NONE => [] + | SOME (FoundStr (name, sgn)) => (case ElabEnv.hnormSgn env sgn of + (Elab.SgnConst sgis, _) => resolvePrefixes env rest (filterSgiItems sgis) + | _ => []) + | SOME (FoundCon (name, c)) => + let + val fields = case ElabOps.reduceCon env c of + (Elab.TRecord (Elab.CRecord (_, fields), l2_), l1_) => + fields + | ( ( Elab.CApp + ( ( (Elab.CApp + ( ( Elab.CModProj (_, _, "sql_table") , l4_) + , ( Elab.CRecord (_, fields) , l3_))) + , l2_) + , _)) + , l1_) => fields + | _ => [] + val items = + List.mapPartial (fn (c1, c2) => case c1 of + (Elab.CName fieldName, _) => SOME (FoundCon (fieldName, c2)) + | _ => NONE) fields + in + resolvePrefixes env rest items + end + | SOME (FoundKind (_, _)) => []) + + +fun findStringInEnv' (env: ElabEnv.env) (preferCon: bool) (str: string): (string (* prefix *) * foundInEnv option) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.find (fn i => getNameOfFoundInEnv i = query) afterResolve) + end + +fun matchStringInEnv' (env: ElabEnv.env) (str: string): (string (* prefix *) * foundInEnv list) = + let + val splitted = List.map Substring.string (Substring.fields (fn c => c = #".") (Substring.full str)) + val afterResolve = resolvePrefixes env (List.take (splitted, List.length splitted - 1)) + ( List.map (fn (name, (_, sgn)) => FoundStr (name, sgn)) (ElabEnv.dumpStrs env) + @ List.map FoundKind (ElabEnv.dumpCs env) + @ List.map FoundCon (ElabEnv.dumpEs env)) + val query = List.last splitted + val prefix = String.extract (str, 0, SOME (String.size str - String.size query)) + in + (prefix, List.filter (fn i => String.isPrefix query (getNameOfFoundInEnv i)) afterResolve) + end + +fun getDesc item = + case item of + Kind (_, s) => "Kind " ^ ErrorMsg.spanToString s + | Con (_, s) => "Con " ^ ErrorMsg.spanToString s + | Exp (_, s) => "Exp " ^ ErrorMsg.spanToString s + | Sgn_item (_, s) => "Sgn_item " ^ ErrorMsg.spanToString s + | Sgn (_, s) => "Sgn " ^ ErrorMsg.spanToString s + | Str (_, s) => "Str " ^ ErrorMsg.spanToString s + | Decl (_, s) => "Decl " ^ ErrorMsg.spanToString s + +fun matchStringInEnv env str fileName pos query: (ElabEnv.env * string (* prefix *) * foundInEnv list) = + let + val {item = _, env} = findClosestSpan env str fileName pos + val (prefix, matches) = matchStringInEnv' env query + in + (env, prefix, matches) + end + +fun findStringInEnv env str fileName pos (query: string): (ElabEnv.env * string (* prefix *) * foundInEnv option) = + let + val {item, env} = findClosestSpan env str fileName pos + val env = case item of + Exp (L.ECase _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.ELet _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp (L.EAbs _, _) => #env (findFirstExpAfter env str fileName pos) + | Exp e => env + | Con _ => #env (findFirstExpAfter env str fileName pos) + | _ => #env (findFirstExpAfter env str fileName pos) + val preferCon = case item of Con _ => true + | _ => false + val (prefix, found) = findStringInEnv' env preferCon query + in + (env, prefix, found) + end +end diff --git a/src/json.sig b/src/json.sig new file mode 100644 index 00000000..f92ef495 --- /dev/null +++ b/src/json.sig @@ -0,0 +1,13 @@ +signature JSON = sig + datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + + val parse: string -> json + val print: json -> string +end diff --git a/src/json.sml b/src/json.sml new file mode 100644 index 00000000..81d7b8b4 --- /dev/null +++ b/src/json.sml @@ -0,0 +1,293 @@ +(******************************************************************************* +* Standard ML JSON parser +* Copyright (C) 2010 Gian Perrone +* +* This program is free software: you can redistribute it and/or modify +* it under the terms of the GNU General Public License as published by +* the Free Software Foundation, either version 3 of the License, or +* (at your option) any later version. +* +* This program is distributed in the hope that it will be useful, +* but WITHOUT ANY WARRANTY; without even the implied warranty of +* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +* GNU General Public License for more details. +* +* You should have received a copy of the GNU General Public License +* along with this program. If not, see <http://www.gnu.org/licenses/>. +******************************************************************************) + +signature JSON_CALLBACKS = +sig + type json_data + + val json_object : json_data list -> json_data + val json_pair : string * json_data -> json_data + val json_array : json_data list -> json_data + val json_value : json_data -> json_data + val json_string : string -> json_data + val json_int : int -> json_data + val json_real : real -> json_data + val json_bool : bool -> json_data + val json_null : unit -> json_data + + val error_handle : string * int * string -> json_data +end + +functor JSONParser (Callbacks : JSON_CALLBACKS) = +struct + type json_data = Callbacks.json_data + + exception JSONParseError of string * int + + val inputData = ref "" + val inputPosition = ref 0 + + fun isDigit () = Char.isDigit (String.sub (!inputData,0)) + + fun ws () = while (String.isPrefix " " (!inputData) orelse + String.isPrefix "\n" (!inputData) orelse + String.isPrefix "\t" (!inputData) orelse + String.isPrefix "\r" (!inputData)) + do (inputData := String.extract (!inputData, 1, NONE)) + + fun peek () = String.sub (!inputData,0) + fun take () = + String.sub (!inputData,0) before + inputData := String.extract (!inputData, 1, NONE) + + fun matches s = (ws(); String.isPrefix s (!inputData)) + fun consume s = + if matches s then + (inputData := String.extract (!inputData, size s, NONE); + inputPosition := !inputPosition + size s) + else + raise JSONParseError ("Expected '"^s^"'", !inputPosition) + + fun parseObject () = + if not (matches "{") then + raise JSONParseError ("Expected '{'", !inputPosition) + else + (consume "{"; ws (); + if matches "}" then Callbacks.json_object [] before consume "}" + else + (Callbacks.json_object (parseMembers ()) + before (ws (); consume "}"))) + + and parseMembers () = + parsePair () :: + (if matches "," then (consume ","; parseMembers ()) else []) + + and parsePair () = + Callbacks.json_pair (parseString (), + (ws(); consume ":"; ws(); parseValue ())) + + and parseArray () = + if not (matches "[") then + raise JSONParseError ("Expected '['", !inputPosition) + else + (consume "["; + if matches "]" then + Callbacks.json_array [] before consume "]" + else + Callbacks.json_array (parseElements ()) before (ws (); consume "]")) + + and parseElements () = + parseValue () :: + (if matches "," then (consume ","; parseElements ()) else []) + + and parseValue () = + Callbacks.json_value ( + if matches "\"" then Callbacks.json_string (parseString ()) else + if matches "-" orelse isDigit () then parseNumber () else + if matches "true" then Callbacks.json_bool true before consume "true" else + if matches "false" then Callbacks.json_bool false before consume "false" else + if matches "null" then Callbacks.json_null () before consume "null" else + if matches "[" then parseArray () else + if matches "{" then parseObject () else + raise JSONParseError ("Expected value", !inputPosition)) + + and parseString () = + (ws () ; + consume ("\"") ; + parseChars () before consume "\"") + + and parseChars () = + let + val escapedchars = ["n", "r", "b", "f", "t"] + fun pickChars s = + if peek () = #"\"" (* " = end of string *) + then s + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"\"" + then (consume "\\\""; pickChars (s ^ "\"")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"n" + then (consume "\\\\n"; pickChars (s ^ "\\n")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"n" + then (consume "\\n"; pickChars (s ^ "\n")) + else + if peek () = #"\\" andalso String.sub (!inputData, 1) = #"\\" andalso String.sub (!inputData, 2) = #"r" + then (consume "\\\\r"; pickChars (s ^ "\\r")) + else + if peek () = #"\\" andalso (String.sub (!inputData, 1)) = #"r" + then (consume "\\r"; pickChars (s ^ "\r")) + else pickChars (s ^ String.str (take ())) + in + pickChars "" + end + + and parseNumber () = + let + val i = parseInt () + in + if peek () = #"e" orelse peek () = #"E" then + Callbacks.json_int (valOf (Int.fromString (i^parseExp()))) + else if peek () = #"." then + let + val f = parseFrac() + + val f' = if peek() = #"e" orelse peek() = #"E" then + i ^ f ^ parseExp () + else i ^ f + in + Callbacks.json_real (valOf (Real.fromString f')) + end + else Callbacks.json_int (valOf (Int.fromString i)) + end + + and parseInt () = + let + val f = + if peek () = #"-" + then (take (); "~") + else String.str (take ()) + in + f ^ parseDigits () + end + + and parseDigits () = + let + val r = ref "" + in + (while Char.isDigit (peek ()) do + r := !r ^ String.str (take ()); + !r) + end + + and parseFrac () = + (consume "." ; + "." ^ parseDigits ()) + + and parseExp () = + let + val _ = + if peek () = #"e" orelse + peek () = #"E" then take () + else + raise JSONParseError ("Invalid number", !inputPosition) + + val f = if peek () = #"-" then (take (); "~") + else if peek () = #"+" then (take (); "") + else "" + in + "e" ^ f ^ parseDigits () + end + + fun parse s = + (inputData := s ; + inputPosition := 0 ; + parseObject ()) handle JSONParseError (m,p) => + Callbacks.error_handle (m,p,!inputData) +end + +structure JsonIntermAst = +struct +datatype ast = + Array of ast list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Pair of (string * ast) + | Obj of ast list +end + +structure Json :> JSON = struct +datatype json = + Array of json list + | Null + | Float of real + | String of string + | Bool of bool + | Int of int + | Obj of (string * json) list + +fun fromInterm (interm: JsonIntermAst.ast): json = + case interm of + JsonIntermAst.Array l => Array (List.map fromInterm l) + | JsonIntermAst.Null => Null + | JsonIntermAst.Float r => Float r + | JsonIntermAst.String s => String s + | JsonIntermAst.Bool b => Bool b + | JsonIntermAst.Int i => Int i + | JsonIntermAst.Pair (k,v) => + raise Fail ("JSON Parsing error. Pair of JSON found where it shouldn't. Key = " ^ k) + | JsonIntermAst.Obj l => + Obj + (List.foldl + (fn (a, acc) => + case a of + JsonIntermAst.Pair (k, v) => (k, fromInterm v) :: acc + | JsonIntermAst.Array _ => raise Fail ("JSON Parsing error. Found Array in object instead of key-value pair") + | JsonIntermAst.Null => raise Fail ("JSON Parsing error. Found Null in object instead of key-value pair") + | JsonIntermAst.Float _ => raise Fail ("JSON Parsing error. Found Float in object instead of key-value pair") + | JsonIntermAst.String _ => raise Fail ("JSON Parsing error. Found String in object instead of key-value pair") + | JsonIntermAst.Bool _ => raise Fail ("JSON Parsing error. Found Bool in object instead of key-value pair") + | JsonIntermAst.Int _ => raise Fail ("JSON Parsing error. Found Int in object instead of key-value pair") + | JsonIntermAst.Obj _ => raise Fail ("JSON Parsing error. Found Obj in object instead of key-value pair") + ) [] l) + +structure StandardJsonParserCallbacks = +struct + type json_data = JsonIntermAst.ast + fun json_object l = JsonIntermAst.Obj l + fun json_pair (k,v) = JsonIntermAst.Pair (k,v) + fun json_array l = JsonIntermAst.Array l + fun json_value x = x + fun json_string s = JsonIntermAst.String s + fun json_int i = JsonIntermAst.Int i + fun json_real r = JsonIntermAst.Float r + fun json_bool b = JsonIntermAst.Bool b + fun json_null () = JsonIntermAst.Null + fun error_handle (msg,pos,data) = + raise Fail ("Error: " ^ msg ^ " near " ^ Int.toString pos ^ " data: " ^ + data) +end + +structure MyJsonParser = JSONParser (StandardJsonParserCallbacks) + +fun parse (str: string): json = + fromInterm (MyJsonParser.parse str) +fun print (ast: json): string = + case ast of + Array l => "[" + ^ List.foldl (fn (a, acc) => acc ^ (if acc = "" then "" else ", ") ^ print a) "" l + ^ "]" + | Null => "null" + | Float r => Real.toString r + | String s => + "\"" ^ + String.translate + (fn c => if c = #"\"" then "\\\"" else Char.toString c) + s ^ + "\"" + | Bool b => if b then "true" else "false" + | Int i => if i >= 0 + then (Int.toString i) + else "-" ^ (Int.toString (Int.abs i)) (* default printing uses ~ instead of - *) + | Obj l => "{" + ^ List.foldl (fn ((k, v), acc) => acc ^ (if acc = "" then "" else ", ") ^ "\"" ^ k ^ "\": " ^ print v ) "" l + ^ "}" +end diff --git a/src/lsp.sig b/src/lsp.sig new file mode 100644 index 00000000..0dc95801 --- /dev/null +++ b/src/lsp.sig @@ -0,0 +1,3 @@ +signature LSP = sig + val startServer : unit -> unit +end diff --git a/src/lsp.sml b/src/lsp.sml new file mode 100644 index 00000000..c99a6f2e --- /dev/null +++ b/src/lsp.sml @@ -0,0 +1,514 @@ +structure Lsp :> LSP = struct + +structure C = Compiler +structure P = Print + +val debug = LspSpec.debug + +structure SK = struct + type ord_key = string + val compare = String.compare +end +structure SM = BinaryMapFn(SK) + +type fileState = + { envBeforeThisModule: ElabEnv.env + , decls: Elab.decl list + , text: string} +type state = + { urpPath : string + , fileStates : fileState SM.map + } + +(* Wrapping this in structure as an attempt to not get concurrency bugs *) +structure State : + sig + val init: state -> unit + val insertText: string -> string -> unit + val insertElabRes: string -> ElabEnv.env -> Elab.decl list -> unit + val removeFile: string -> unit + val withState: (state -> 'a) -> 'a + end = struct +val stateRef = ref (NONE: state option) +fun init (s: state) = + stateRef := SOME s +fun withState (f: state -> 'a): 'a = + case !stateRef of + NONE => raise LspSpec.LspError LspSpec.ServerNotInitialized + | SOME s => f s + +fun insertText (fileName: string) (text: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = [] + , envBeforeThisModule = ElabEnv.empty }) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = text + , decls = #decls oldfs + , envBeforeThisModule = #envBeforeThisModule oldfs }) + } + ) + +fun insertElabRes (fileName: string) (env: ElabEnv.env) decls = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = + case SM.find (#fileStates oldS, fileName) of + NONE => raise Fail ("No text found for file " ^ fileName) + | SOME oldfs => + SM.insert ( #fileStates oldS + , fileName + , { text = #text oldfs + , decls = decls + , envBeforeThisModule = env }) + } + ) + +fun removeFile (fileName: string) = + withState (fn oldS => + stateRef := SOME { urpPath = #urpPath oldS + , fileStates = #1 (SM.remove (#fileStates oldS, fileName)) + } + ) + +end + + + +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +(* Throws Fail if can't init *) +fun initState (initParams: LspSpec.initializeParams): state = + let + val rootPath = case #rootUri initParams of + NONE => raise Fail "No rootdir found" + | SOME a => #path a + val optsUrpFile = + (SOME (FromJson.asString (FromJson.get "urpfile" (FromJson.get "project" (FromJson.get "urweb" (#initializationOptions initParams)))))) + handle ex => NONE + val foundUrps = scanDir (fn fname => OS.Path.ext fname = SOME "urp") rootPath + in + { urpPath = case foundUrps of + [] => raise Fail ("No .urp files found in path " ^ rootPath) + | one :: [] => OS.Path.base (OS.Path.file one) + | many => case List.find (fn m => SOME (OS.Path.base (OS.Path.file m)) = optsUrpFile) many of + NONE => raise Fail ("Found multiple .urp files in path " ^ rootPath) + | SOME f => OS.Path.base (OS.Path.file f) + , fileStates = SM.empty + } + end + +fun addSgnToEnv (env: ElabEnv.env) (sgn: Source.sgn_item list) (fileName: string) (addUnprefixed: bool): ElabEnv.env = + let + val moduleName = C.moduleOf fileName + val (sgn, gs) = Elaborate.elabSgn (env, Disjoint.empty) (Source.SgnConst sgn, { file = fileName + , first = ErrorMsg.dummyPos + , last = ErrorMsg.dummyPos }) + val () = case gs of + [] => () + | _ => (app (fn (_, env, _, c1, c2) => + Print.prefaces "Unresolved" + [("c1", ElabPrint.p_con env c1), + ("c2", ElabPrint.p_con env c2)]) gs; + raise Fail ("Unresolved disjointness constraints in " ^ moduleName ^ " at " ^ fileName)) (* TODO Not sure if this is needed for all signatures or only for Basis *) + val (env', n) = ElabEnv.pushStrNamed env moduleName sgn + val (_, env') = if addUnprefixed + then Elaborate.dopen env' {str = n, strs = [], sgn = sgn} + else ([], env') + in + env' + end + +fun errorToDiagnostic (err: { span: ErrorMsg.span , message: string }): LspSpec.diagnostic = + { range = { start = { line = #line (#first (#span err)) - 1 + , character = #char (#first (#span err)) + } + , end_ = { line = #line (#last (#span err)) - 1 + , character = #char (#last (#span err)) + } + } + , severity = 1 + , source = "UrWeb" + , message = #message err + } + +(* TODO FFI modules ? Check compiler.sml -> parse -> parseFfi *) +(* TODO Optim: cache parsed urp file? *) +fun elabFile (state: state) (fileName: string): ({ decls: Elab.decl list, envBeforeThisModule: ElabEnv.env} option * LspSpec.diagnostic list) = + let + val () = if (OS.Path.ext fileName = SOME "ur") + then () + else raise Fail ("Can only handle .ur files for now") + (* val () = Elaborate.unifyMore := true *) + (* To reuse Basis and Top *) + val () = Elaborate.incremental := true + (* Parsing .urp *) + val job = case C.run (C.transform C.parseUrp "parseUrp") (#urpPath state) of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Couldn't parse .urp file at " ^ (#urpPath state))) + | SOME a => a + val moduleSearchRes = + List.foldl + (fn (entry, acc) => if #2 acc + then acc + else + if entry ^ ".ur" = fileName + then (List.rev (#1 acc), true) + else (entry :: #1 acc, false)) + ([] (* modules before *), false (* module found *)) + (#ffi job @ #sources job) + val modulesBeforeThisFile = #1 moduleSearchRes + val () = if #2 moduleSearchRes + then () + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find file " ^ fileName ^ " referenced in .urp file at " ^ (#urpPath state))) + (* Parsing .urs files of previous modules *) + val parsedUrss = List.map (fn entry => + if OS.FileSys.access (entry ^ ".urs", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".urs") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse .urs file at " ^ entry)) + | SOME a => { fileName = entry ^ ".urs", parsed = a} + else + if OS.FileSys.access (entry ^ ".ur", []) + then case C.run (C.transform C.parseUrs "parseUrs") (entry ^ ".ur") of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("No .urs file found for " ^ entry ^ " and couldn't parse .ur as .urs file")) + | SOME a => { fileName = entry ^ ".ur" , parsed = a} + else raise LspSpec.LspError (LspSpec.InternalError ("Couldn't find an .ur or .urs file for " ^ entry))) + modulesBeforeThisFile + (* Parsing Basis and Top *) + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + + val parsedBasisUrs = + case C.run (C.transform C.parseUrs "parseUrs") basisF of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse basis.urs file at " ^ basisF)) + | SOME a => a + val parsedTopUrs = + case C.run (C.transform C.parseUrs "parseUrs") topF of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.urs file at " ^ topF)) + | SOME a => a + val parsedTopUr = + case C.run (C.transform C.parseUr "parseUr") topF' of + NONE => raise LspSpec.LspError (LspSpec.InternalError ("Failed to parse top.ur file at " ^ topF')) + | SOME a => a + + (* Parsing .ur and .urs of current file *) + val (parsedUrs: Source.sgn option) = + (if OS.FileSys.access (fileName ^ "s", []) + then + case C.run (C.transform C.parseUrs "parseUrs") (fileName ^ "s") of + NONE => NONE + | SOME a => SOME ( Source.SgnConst a + , {file = fileName ^ "s", first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos}) + else + NONE) handle ex => NONE + val () = ErrorMsg.resetErrors () + val (parsedUrO: (Source.decl list) option) = + C.run (C.transform C.parseUr "parseUr") fileName + in + case parsedUrO of + NONE => (* Parse error *) (NONE, List.map errorToDiagnostic (ErrorMsg.readErrorLog ())) + | SOME parsedUr => + (* Parsing of .ur succeeded *) + let + val loc = {file = fileName, first = ErrorMsg.dummyPos, last = ErrorMsg.dummyPos} + val envBeforeThisModule = ref ElabEnv.empty + val res = Elaborate.elabFile + parsedBasisUrs tm1 parsedTopUr parsedTopUrs tm2 ElabEnv.empty + (* Adding urs's of previous modules to env *) + (fn envB => + let + val newEnv = List.foldl (fn (sgn, env) => addSgnToEnv env (#parsed sgn) (#fileName sgn) false) envB parsedUrss + in + (envBeforeThisModule := newEnv; newEnv) + end + ) + [( Source.DStr (C.moduleOf fileName, parsedUrs, NONE, (Source.StrConst parsedUr, loc), false) + , loc )] + (* report back errors (as Diagnostics) *) + val errors = ErrorMsg.readErrorLog () + val decls = case List.last res of + (Elab.DStr (_, _, _, (Elab.StrConst decls, _)), _) => decls + | _ => raise Fail ("Impossible: Source.StrConst did not become Elab.StrConst after elaboration") + in + (SOME { envBeforeThisModule = !envBeforeThisModule, decls = decls }, + List.map errorToDiagnostic errors) + end + end + +fun uniq (eq: 'b -> 'b -> bool) (bs: 'b list) = + case bs of + [] => [] + | (l as b :: bs') => b :: uniq eq (List.filter (fn a => not (eq a b)) bs') + +fun elabFileAndSendDiags (state: state) (toclient: LspSpec.toclient) (documentUri: LspSpec.documentUri): unit = + let + val fileName = #path documentUri + val res = elabFile state fileName + fun eq_diag (d1: LspSpec.diagnostic) (d2: LspSpec.diagnostic) = #range d1 = #range d2 andalso #message d1 = #message d2 + val diags = uniq eq_diag (#2 res) + in + (case #1 res of + NONE => () + | SOME fs => + (State.insertElabRes fileName (#envBeforeThisModule fs) (#decls fs)); + #publishDiagnostics toclient { uri = documentUri , diagnostics = diags}) + end + +fun scanDir (f: string -> bool) (path: string) = + let + val dir = OS.FileSys.openDir path + fun doScanDir acc = + case OS.FileSys.readDir dir of + NONE => (OS.FileSys.closeDir dir; acc) + | SOME fname => + (if f fname + then doScanDir (fname :: acc) + else doScanDir acc) + in + doScanDir [] + end + +fun readFile (fileName: string): string = + let + val stream = TextIO.openIn fileName + fun doReadFile acc = + case TextIO.inputLine stream of + NONE => acc + | SOME str => (if acc = "" + then doReadFile str + else doReadFile (acc ^ str)) + val res = doReadFile "" + in + (TextIO.closeIn stream; res) + end + + +(* TODO PERF BIG I couldn't figure out how to print just to a string, so writing to a temp file, then reading it, then deleting it, ... *) +fun ppToString (pp: Print.PD.pp_desc) (width: int): string = + let + val tempfile = OS.FileSys.tmpName () + val outStr = TextIO.openOut tempfile + val outDev = TextIOPP.openOut {dst = outStr, wid = width} + val () = Print.fprint outDev pp + val res = readFile tempfile + val () = TextIO.closeOut outStr + in + res + end + +fun getStringAtCursor + (stopAtCursor: bool) + (text: string) + (pos: LspSpec.position) + : string + = + let + val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full text), #line pos) + val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":", #"@" + , #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"] + val lineUntilCursor = Substring.slice (line, 0, SOME (#character pos)) + val beforeCursor = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilCursor) + val afterCursor = if stopAtCursor + then "" + else let + val lineAfterCursor = Substring.slice (line, #character pos, NONE) + in + Substring.string (Substring.takel (fn c => not (List.exists (fn c' => c = c') (#"." :: chars))) lineAfterCursor) + end + in + beforeCursor ^ afterCursor + end + +fun formatTypeBox (a: P.PD.pp_desc, b: P.PD.pp_desc) = + P.PD.hvBox (P.PD.PPS.Rel 0, [a, + P.PD.string ": ", + P.PD.break {nsp = 0, offset = 2}, + b]) + +fun handleHover (state: state) (p: LspSpec.hoverReq): LspSpec.hoverResp LspSpec.result = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success NONE + | SOME s => + let + val searchString = getStringAtCursor false (#text s) (#position p) + val env = #envBeforeThisModule s + val decls = #decls s + val loc = #position p + val (env, prefix, found) = GetInfo.findStringInEnv env (Elab.StrConst decls) fileName { line = #line loc + 1 + , char = #character loc + 1} searchString + in + case found of + NONE => LspSpec.Success NONE + | SOME f => + let + val desc = case f of + GetInfo.FoundStr (x, (_, sgn)) => formatTypeBox (P.PD.string (prefix ^ x), P.PD.string "module") + | GetInfo.FoundKind (x, kind) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_kind env kind) + | GetInfo.FoundCon (x, con) => formatTypeBox (P.PD.string (prefix ^ x), ElabPrint.p_con env con) + in + LspSpec.Success (SOME {contents = ppToString desc 50}) + end + end + end + +(* TODO IDEA can we use the real parser to figure out what we're typing (exp, con, field, etc) to predict better? *) +fun handleCompletion (state: state) (p: LspSpec.completionReq) = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => LspSpec.Success { isIncomplete = false, items = []} + | SOME s => + let + val pos = #position p + val searchStr = getStringAtCursor true (#text s) pos + val env = #envBeforeThisModule s + val decls = #decls s + val (env, prefix, foundItems) = GetInfo.matchStringInEnv env (Elab.StrConst decls) fileName { line = #line pos + 1, char = #character pos + 1} searchStr + val completions = List.map + (fn f => case f of + GetInfo.FoundStr (x, _) => {label = prefix ^ x, kind = LspSpec.Module, detail = ""} + | GetInfo.FoundKind (x, k) => {label = prefix ^ x, kind = LspSpec.Constructor, detail = ppToString (ElabPrint.p_kind env k) 200} + | GetInfo.FoundCon (x, c) => {label = prefix ^ x, kind = LspSpec.Value, detail = ppToString (ElabPrint.p_con env c) 200} + ) + foundItems + in + LspSpec.Success { isIncomplete = false + , items = completions } + end + end + +fun applyContentChange ((c, s): LspSpec.contentChange * string): string = + case (#range c, #rangeLength c) of + (SOME range, SOME _) => + let + val lines = Substring.fields (fn c => c = #"\n") (Substring.full s) + val linesBefore = List.take (lines, #line (#start range)) + val linesAfter = List.drop (lines, #line (#end_ range) + 1) + val startLine = List.nth (lines, #line (#start range)) + val startText = Substring.slice (startLine, 0, SOME (#character (#start range))) + val endLine = List.nth (lines, #line (#end_ range)) + val endText = Substring.triml (#character (#end_ range)) endLine + in + Substring.concatWith "\n" (linesBefore + @ [Substring.full (Substring.concat [startText, Substring.full (#text c), endText])] + @ linesAfter) + end + | _ => + #text c + +fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspSpec.didChangeParams): unit = + let + val fileName = #path (#uri (#textDocument p)) + val s = SM.find (#fileStates state, fileName) + in + case s of + NONE => + (debug ("Got change event for file that isn't open: " ^ fileName); + (#showMessage toclient) ("Got change event for file that isn't open: " ^ fileName) 1) + | SOME s => + State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p)) + end + +fun runInBackground (toclient: LspSpec.toclient) (fileName: string) (f: unit -> unit): unit = + BgThread.queueBgTask + fileName + ((fn () => (f () + handle LspSpec.LspError (LspSpec.InternalError str) => (#showMessage toclient) str 1 + | LspSpec.LspError LspSpec.ServerNotInitialized => (#showMessage toclient) "Server not initialized" 1 + | ex => (#showMessage toclient) (General.exnMessage ex) 1 + ; (#showMessage toclient) ("Done running BG job for " ^ fileName) 3 + ))) + +fun handleRequest (requestMessage: LspSpec.message) = + case requestMessage of + LspSpec.Notification n => + LspSpec.matchNotification + n + { initialized = fn () => () + , textDocument_didOpen = + fn (p, toclient) => + (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)); + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))))) + , textDocument_didChange = + fn (p, toclient) => + State.withState (fn state => handleDocumentDidChange state toclient p) + , textDocument_didSave = + fn (p, toclient) => + runInBackground + toclient + (#path (#uri (#textDocument p))) + (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))) + , textDocument_didClose = + fn (p, toclient) => + State.removeFile (#path (#uri (#textDocument p))) + } + | LspSpec.RequestMessage m => + (* TODO should error handling here be inside handleMessage? *) + LspSpec.matchMessage + m + { initialize = fn p => + (let val st = initState p + in + State.init st; + LspSpec.Success + { capabilities = + { hoverProvider = true + , completionProvider = SOME { triggerCharacters = ["."]} + , textDocumentSync = { openClose = true + , change = 2 + , save = SOME { includeText = false } + }} + } + end) + , shutdown = fn () => LspSpec.Success () + , textDocument_hover = fn toclient => State.withState handleHover + , textDocument_completion = fn p => State.withState (fn s => handleCompletion s p) + } + +fun serverLoop () = + if not (Option.isSome (TextIO.canInput (TextIO.stdIn, 1))) andalso BgThread.hasBgTasks () + then + (* no input waiting -> give control to lower prio thread *) + BgThread.runBgTaskForABit () + else + let + val requestMessage = + LspSpec.readRequestFromStdIO () + handle ex => (debug ("Error in reading from stdIn: " ^ General.exnMessage ex) ; raise ex) + in + handleRequest requestMessage + end + +fun startServer () = while true do serverLoop () +end diff --git a/src/lspspec.sml b/src/lspspec.sml new file mode 100644 index 00000000..0d766056 --- /dev/null +++ b/src/lspspec.sml @@ -0,0 +1,450 @@ +structure LspSpec = struct + + datatype lspError = InternalError of string + | ServerNotInitialized + exception LspError of lspError + + fun debug (str: string): unit = + (TextIO.output (TextIO.stdErr, str ^ "\n\n"); TextIO.flushOut TextIO.stdErr) + + fun trim (s: substring): substring = + Substring.dropr Char.isSpace (Substring.dropl Char.isSpace s) + + fun readHeader (): (string * string) option = + let + val line = TextIO.inputLine TextIO.stdIn + in + case line of + NONE => OS.Process.exit OS.Process.success + | SOME str => + if Substring.isEmpty (trim (Substring.full str)) + then NONE + else + let + val (key, value) = Substring.splitl (fn c => c <> #":") (Substring.full str) + in + if Substring.isEmpty (trim value) + then raise Fail ("Failed to parse LSP header: Line is not empty but is also not a valid header: " ^ str) + else SOME ( Substring.string (trim key) + , Substring.string (trim (Substring.dropl (fn c => c = #":") (trim value)))) + end + end + + fun readAllHeaders (): (string * string) list = + let + fun doReadAllHeaders (l: (string * string) list): (string * string) list = + case readHeader () of + NONE => l + | SOME tup => tup :: doReadAllHeaders l + + in + doReadAllHeaders [] + end + datatype message = + RequestMessage of { id: Json.json, method: string, params: Json.json} + | Notification of { method: string, params: Json.json} + fun parseMessage (j: Json.json): message = + let + val id = SOME (FromJson.get "id" j) + handle ex => NONE + val method = FromJson.asString (FromJson.get "method" j) + val params = FromJson.get "params" j + in + case id of + NONE => Notification {method = method, params = params} + | SOME id => RequestMessage {id = id, method = method, params = params} + end + + type documentUri = + { scheme: string + , authority: string + , path: string + , query: string + , fragment: string + } + fun parseDocumentUri (str: string): documentUri = + let + val str = Substring.full str + val (scheme, rest) = Substring.splitl (fn c => c <> #":") str + val (authority, rest) = Substring.splitl (fn c => c <> #"/") (Substring.triml 3 rest (* :// *)) + val (path, rest) = Substring.splitl (fn c => c <> #"?" orelse c <> #"#") rest + val (query, rest) = if Substring.first rest = SOME #"?" + then Substring.splitl (fn c => c <> #"#") (Substring.triml 1 rest (* ? *)) + else (Substring.full "", rest) + val fragment = if Substring.first rest = SOME #"#" + then (Substring.triml 1 rest (* # *)) + else Substring.full "" + + in + { scheme = Substring.string scheme + , authority = Substring.string authority + , path = Substring.string path + , query = Substring.string query + , fragment = Substring.string fragment + } + end + fun printDocumentUri (d: documentUri) = + (#scheme d) ^ "://" ^ + (#authority d) ^ + (#path d) ^ + (if #query d <> "" then "?" ^ #query d else "") ^ + (if #fragment d <> "" then "#" ^ #fragment d else "") + + type textDocumentIdentifier = { uri: documentUri} + fun parseTextDocumentIdentifier (j: Json.json): textDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j))} + + type versionedTextDocumentIdentifier = + { uri: documentUri + , version: int option + } + fun parseVersionedTextDocumentIdentifier (j: Json.json): versionedTextDocumentIdentifier = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , version = FromJson.asOptionalInt (FromJson.get "version" j) + } + + type textDocumentItem = { + uri: documentUri, + languageId: string, + version: int, (* The version number of this document (it will increase after each change, including undo/redo). *) + text: string + } + fun parseTextDocumentItem (j: Json.json) = + { uri = parseDocumentUri (FromJson.asString (FromJson.get "uri" j)) + , languageId = FromJson.asString (FromJson.get "languageId" j) + , version = FromJson.asInt (FromJson.get "version" j) + , text = FromJson.asString (FromJson.get "text" j) + } + + type position = { line: int + , character: int + } + fun parsePosition (j: Json.json) = + { line = FromJson.asInt (FromJson.get "line" j) + , character = FromJson.asInt (FromJson.get "character" j) + } + fun printPosition (p: position): Json.json = Json.Obj [ ("line", Json.Int (#line p)) + , ("character", Json.Int (#character p))] + + type range = { start: position + , end_: position } + fun parseRange (j: Json.json): range = + { start = parsePosition (FromJson.get "start" j) + , end_ = parsePosition (FromJson.get "end" j) + } + fun printRange (r: range): Json.json = Json.Obj [ ("start", printPosition (#start r)) + , ("end", printPosition (#end_ r))] + + fun readRequestFromStdIO (): message = + let + val headers = readAllHeaders () + val lengthO = List.find (fn (k,v) => k = "Content-Length") headers + val request = case lengthO of + NONE => raise Fail "No header with Content-Length found" + | SOME (k, v) => + case Int.fromString v of + NONE => raise Fail ("Couldn't parse content-length from string: " ^ v) + | SOME i => TextIO.inputN (TextIO.stdIn, i) + val parsed = Json.parse request + in + parseMessage parsed + end + + type hoverReq = { textDocument: textDocumentIdentifier , position: position } + type hoverResp = {contents: string} option + fun parseHoverReq (params: Json.json): hoverReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + , position = parsePosition (FromJson.get "position" params) + } + fun printHoverResponse (resp: hoverResp): Json.json = + case resp of + NONE => Json.Null + | SOME obj => Json.Obj [("contents", Json.String (#contents obj))] + + type didOpenParams = { textDocument: textDocumentItem } + fun parseDidOpenParams (params: Json.json): didOpenParams = + { textDocument = parseTextDocumentItem (FromJson.get "textDocument" params) } + + type contentChange = { range: range option + , rangeLength: int option + , text: string } + type didChangeParams = + { textDocument: versionedTextDocumentIdentifier + , contentChanges: contentChange list + } + fun parseDidChangeParams (params: Json.json): didChangeParams = + { textDocument = parseVersionedTextDocumentIdentifier (FromJson.get "textDocument" params) + , contentChanges = case FromJson.get "contentChanges" params of + Json.Array js => + List.map (fn j => { range = Option.map parseRange (FromJson.getO "range" j) + , rangeLength = Option.map FromJson.asInt (FromJson.getO "rangeLength" j) + , text = FromJson.asString (FromJson.get "text" j) + } + ) js + | j => raise Fail ("Expected JSON array, got: " ^ Json.print j) + } + + type didSaveParams = { textDocument: textDocumentIdentifier } + fun parseDidSaveParams (params: Json.json): didSaveParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + (* , text = ... *) + } + type didCloseParams = { textDocument: textDocumentIdentifier } + fun parseDidCloseParams (params: Json.json): didCloseParams = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" params) + } + type initializeParams = + { rootUri: documentUri option + , initializationOptions: Json.json } + fun parseInitializeParams (j: Json.json) = + { rootUri = + Option.map + parseDocumentUri + (FromJson.asOptionalString (FromJson.get "rootUri" j)) + , initializationOptions = FromJson.get "initializationOptions" j + } + type diagnostic = { range: range + (* code?: number | string *) + , severity: int (* 1 = error, 2 = warning, 3 = info, 4 = hint*) + , source: string + , message: string + (* relatedInformation?: DiagnosticRelatedInformation[]; *) + } + fun printDiagnostic (d: diagnostic): Json.json = + Json.Obj [ ("range", printRange (#range d)) + , ("severity", Json.Int (#severity d)) + , ("source", Json.String (#source d)) + , ("message", Json.String (#message d)) + ] + type publishDiagnosticsParams = { uri: documentUri + , diagnostics: diagnostic list + } + fun printPublishDiagnosticsParams (p: publishDiagnosticsParams): Json.json = + Json.Obj [ ("uri", Json.String (printDocumentUri (#uri p))) + , ("diagnostics", Json.Array (List.map printDiagnostic (#diagnostics p)))] + + type completionReq = + { textDocument: textDocumentIdentifier + , position: position + , context: { triggerCharacter: string option + , triggerKind: int (* 1 = Invoked = typing an identifier or manual invocation or API + 2 = TriggerCharacter + 3 = TriggerForIncompleteCompletions*)} option + } + fun parseCompletionReq (j: Json.json): completionReq = + { textDocument = parseTextDocumentIdentifier (FromJson.get "textDocument" j) + , position = parsePosition (FromJson.get "position" j) + , context = case FromJson.getO "context" j of + NONE => NONE + | SOME ctx => SOME { triggerCharacter = Option.map FromJson.asString (FromJson.getO "triggerCharacter" ctx) + , triggerKind = FromJson.asInt (FromJson.get "triggerKind" ctx) + } + } + + datatype completionItemKind = Text | Method | Function | Constructor | Field | Variable | Class | Interface | Module | Property | Unit | Value | Enum | Keyword | Snippet | Color | File | Reference | Folder | EnumMember | Constant | Struct | Event | Operator | TypeParameter + fun completionItemKindToInt (a: completionItemKind) = + case a of + Text => 1 + | Method => 2 + | Function => 3 + | Constructor => 4 + | Field => 5 + | Variable => 6 + | Class => 7 + | Interface => 8 + | Module => 9 + | Property => 10 + | Unit => 11 + | Value => 12 + | Enum => 13 + | Keyword => 14 + | Snippet => 15 + | Color => 16 + | File => 17 + | Reference => 18 + | Folder => 19 + | EnumMember => 20 + | Constant => 21 + | Struct => 22 + | Event => 23 + | Operator => 24 + | TypeParameter => 25 + + type completionItem = { label: string + , kind: completionItemKind + , detail: string + } + type completionResp = { isIncomplete: bool + , items: completionItem list + } + + fun printCompletionItem (a: completionItem): Json.json = + Json.Obj [ ("label", Json.String (#label a)) + , ("kind", Json.Int (completionItemKindToInt (#kind a))) + , ("detail", Json.String (#detail a)) + ] + fun printCompletionResp (a: completionResp): Json.json = + Json.Obj [ ("isIncomplete", Json.Bool (#isIncomplete a)) + , (("items", Json.Array (List.map printCompletionItem (#items a))))] + + type initializeResponse = { capabilities: + { hoverProvider: bool + , completionProvider: {triggerCharacters: string list} option + , textDocumentSync: + { openClose: bool + , change: int (* 0 = None, 1 = Full, 2 = Incremental *) + , save: { includeText: bool } option + } + }} + fun printInitializeResponse (res: initializeResponse) = + Json.Obj [("capabilities", + let + val capabilities = #capabilities res + in + Json.Obj [ ("hoverProvider", Json.Bool (#hoverProvider capabilities)) + , ("completionProvider", case #completionProvider capabilities of + NONE => Json.Null + | SOME cp => Json.Obj [("triggerCharacters", Json.Array (List.map Json.String (#triggerCharacters cp)))] + ) + , ("textDocumentSync", + let + val textDocumentSync = #textDocumentSync capabilities + in + Json.Obj [ ("openClose", Json.Bool (#openClose textDocumentSync )) + , ("change", Json.Int (#change textDocumentSync)) + , ("save", case #save textDocumentSync of + NONE => Json.Null + | SOME save => Json.Obj [("includeText", Json.Bool (#includeText save) )])] + end + )] + end + )] + + datatype 'a result = + Success of 'a + | Error of (int * string) + + fun mapResult (f: 'a -> 'b) (a: 'a result): 'b result = + case a of + Success contents => Success (f contents) + | Error e => Error e + type toclient = { showMessage: string -> int -> unit + , publishDiagnostics: publishDiagnosticsParams -> unit } + type messageHandlers = + { initialize: initializeParams -> initializeResponse result + , shutdown: unit -> unit result + , textDocument_hover: toclient -> hoverReq -> hoverResp result + , textDocument_completion: completionReq -> completionResp result + } + + fun showMessage str typ = + let + val jsonToPrint = Json.print (Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "window/showMessage") + , ("params", Json.Obj [ ("type", Json.Int typ) + , ("message", Json.String str)]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + fun publishDiagnostics diags = + let + val jsonToPrint = Json.print ((Json.Obj [ ("jsonrpc", Json.String "2.0") + , ("method", Json.String "textDocument/publishDiagnostics") + , ("params", printPublishDiagnosticsParams diags) + ])) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + val toclient: toclient = {showMessage = showMessage, publishDiagnostics = publishDiagnostics} + + fun matchMessage + (requestMessage: {id: Json.json, method: string, params: Json.json}) + (handlers: messageHandlers) + : unit = + let + val result: Json.json result = + ((case #method requestMessage of + "initialize" => + mapResult + printInitializeResponse + ((#initialize handlers) + (parseInitializeParams (#params requestMessage))) + | "textDocument/hover" => + mapResult + printHoverResponse + ((#textDocument_hover handlers) + toclient + (parseHoverReq (#params requestMessage))) + | "textDocument/completion" => + mapResult + printCompletionResp + ((#textDocument_completion handlers) + (parseCompletionReq (#params requestMessage))) + | "shutdown" => + mapResult + (fn () => Json.Null) + ((#shutdown handlers) ()) + | "exit" => + OS.Process.exit OS.Process.success + | method => (debug ("Method not supported: " ^ method); + Error (~32601, "Method not supported: " ^ method))) + handle LspError (InternalError str) => Error (~32603, str) + | LspError ServerNotInitialized => Error (~32002, "Server not initialized") + | ex => Error (~32603, (General.exnMessage ex)) + ) + (* val () = (TextIO.output (TextIO.stdErr, "Got result: " ^ (case result of Success _ => "success\n" *) + (* | Error _ => "error\n")); TextIO.flushOut TextIO.stdErr) *) + in + case result of + Success j => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("result", j) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + | Error (i, err) => + let + val jsonToPrint = + Json.print (Json.Obj [ ("id", #id requestMessage) + , ("jsonrpc", Json.String "2.0") + , ("error", Json.Obj [ ("code", Json.Int i) + , ("message", Json.String err) + ]) + ]) + val toPrint = "Content-Length:" ^ Int.toString (String.size jsonToPrint) ^ "\r\n\r\n" ^ jsonToPrint + in + TextIO.print toPrint + end + end + + type notificationHandlers = + { initialized: unit -> unit + , textDocument_didOpen: (didOpenParams * toclient) -> unit + , textDocument_didChange: (didChangeParams * toclient) -> unit + , textDocument_didSave: (didSaveParams * toclient) -> unit + , textDocument_didClose: (didCloseParams * toclient) -> unit + } + fun matchNotification + (notification: {method: string, params: Json.json}) + (handlers: notificationHandlers) + = + (case #method notification of + "initialized" => (#initialized handlers) () + | "textDocument/didOpen" => (#textDocument_didOpen handlers) (parseDidOpenParams (#params notification), toclient) + | "textDocument/didChange" => (#textDocument_didChange handlers) (parseDidChangeParams (#params notification), toclient) + | "textDocument/didSave" => (#textDocument_didSave handlers) (parseDidSaveParams (#params notification), toclient) + | "textDocument/didClose" => (#textDocument_didClose handlers) (parseDidCloseParams (#params notification), toclient) + | m => debug ("Notification method not supported: " ^ m)) + handle LspError (InternalError str) => showMessage str 1 + | LspError ServerNotInitialized => showMessage "Server not initialized" 1 + | ex => showMessage (General.exnMessage ex) 1 + +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 1229d552..9042307a 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -43,14 +43,25 @@ fun parse_flags flag_info args = fn (flag1, _, _) => flag0 = flag1 end + fun normalizeArg arg = + case arg of + "-h" => "-help" + | "--h" => "-help" + | "--help" => "-help" + | _ => arg + fun loop [] : string list = [] | loop (arg :: args) = - if String.isPrefix "-" arg then - case List.find (search_pred arg) flag_info of - NONE => raise Fail ("Unknown flag "^arg^", see -help") - | SOME x => exec x args - else - arg :: loop args + let + val arg = normalizeArg arg + in + if String.isPrefix "-" arg then + case List.find (search_pred arg) flag_info of + NONE => raise Fail ("Unknown flag "^arg^", see -help") + | SOME x => exec x args + else + arg :: loop args + end and exec (_, ZERO f, _) args = (f (); loop args) @@ -96,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 @@ -156,7 +169,7 @@ fun oneRun args = ("print-cinclude", ZERO printCInclude, SOME "print directory of C headers and exit"), ("ccompiler", ONE ("<program>", Settings.setCCompiler), - SOME "set the C compiler to <program>"), + SOME "set the C compiler to <program>"), ("demo", ONE ("<prefix>", fn prefix => demo := SOME (prefix, false)), NONE), @@ -164,7 +177,7 @@ fun oneRun args = demo := SOME (prefix, true)), NONE), ("tutorial", set_true tutorial, - NONE), + SOME "render HTML tutorials from .ur source files"), ("protocol", ONE ("[http|cgi|fastcgi|static]", Settings.setProtocol), SOME "set server protocol"), @@ -175,7 +188,7 @@ fun oneRun args = ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms), SOME "select database engine"), ("debug", call_true Settings.setDebug, - NONE), + SOME "save some intermediate C files"), ("verbose", ZERO (fn () => (Compiler.debug := true; Elaborate.verbose := true)), @@ -191,7 +204,8 @@ fun oneRun args = ("unifyMore", set_true Elaborate.unifyMore, SOME "continue unification before reporting type error"), ("dumpSource", set_true Compiler.dumpSource, - NONE), + SOME ("print source code of last intermediate program "^ + "if there is an error")), ("dumpVerboseSource", ZERO (fn () => (Compiler.dumpSource := true; ElabPrint.debug := true; @@ -205,22 +219,26 @@ fun oneRun args = SOME "serve JavaScript as <file>"), ("sql", ONE ("<file>", Settings.setSql o SOME), SOME "output sql script as <file>"), + ("endpoints", ONE ("<file>", Settings.setEndpoints o SOME), + SOME "output exposed URL endpoints in JSON as <file>"), ("static", call_true Settings.setStaticLinking, SOME "enable static linking"), ("stop", ONE ("<phase>", Compiler.setStop), SOME "stop compilation after <phase>"), ("path", TWO ("<name>", "<path>", Compiler.addPath), - NONE), + SOME ("set path variable <name> to <path> for use in "^ + ".urp files")), ("root", TWO ("<name>", "<path>", (fn (name, path) => Compiler.addModuleRoot (path, name))), - NONE), + SOME "prefix names of modules found in <path> with <name>"), ("boot", ZERO (fn () => (Compiler.enableBoot (); Settings.setBootLinking true)), - NONE), + SOME ("run from build tree and generate statically linked "^ + "executables ")), ("sigfile", ONE ("<file>", Settings.setSigFile o SOME), - NONE), + SOME "search for cryptographic signing keys in <file>"), ("iflow", set_true Compiler.doIflow, NONE), ("sqlcache", call_true Settings.setSqlcache, @@ -229,17 +247,19 @@ fun oneRun args = NONE), ("moduleOf", ONE ("<file>", printModuleOf), SOME "print module name of <file> and exit"), + ("startLspServer", ZERO Lsp.startServer, SOME "Start Language Server Protocol server"), ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("<class>", "<num>", add_class), - NONE), + SOME "set resource usage limit for <class> to <num>"), ("explainEmbed", set_true JsComp.explainEmbed, SOME ("explain errors about embedding of server-side "^ "values in client code")) ] 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 @@ -274,7 +294,7 @@ fun oneRun args = else OS.Process.failure | (_, _, true) => (Tutorial.make job; - OS.Process.success) + OS.Process.success) | _ => if !tc then (Compiler.check Compiler.toElaborate job; @@ -302,127 +322,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/marshalcheck.sml b/src/marshalcheck.sml index 8d7edd15..122d3415 100644 --- a/src/marshalcheck.sml +++ b/src/marshalcheck.sml @@ -71,62 +71,87 @@ fun check file = | _ => st fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty + + fun decl (d, (cmap, emap)) = + case d of + DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap) + | DDatatype dts => + (foldl (fn ((_, n, _, xncs), cmap) => + IM.insert (cmap, n, foldl (fn ((_, _, co), s) => + case co of + NONE => s + | SOME c => PS.union (s, sins cmap c)) + PS.empty xncs)) cmap dts, + emap) + + | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag))) + | DValRec vis => (cmap, + foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag))) + emap vis) + + | DExport (_, n, _) => + (case IM.find (emap, n) of + NONE => raise Fail "MarshalCheck: Unknown export" + | SOME (t, tag) => + let + fun makeS (t, _) = + case t of + TFun (dom, ran) => + (case #1 dom of + CFfi ("Basis", "postBody") => makeS ran + | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran + | _ => PS.union (sins cmap dom, makeS ran)) + | _ => PS.empty + val s = makeS t + in + if PS.isEmpty s then + () + else + E.error ("Input to exported function '" + ^ tag ^ "' involves one or more types that are disallowed for page handler inputs: " + ^ PS.toString s); + (cmap, emap) + end) + + | DCookie (_, _, t, tag) => + let + val s = sins cmap t + in + if PS.isEmpty s then + () + else + E.error ("Cookie '" ^ tag ^ "' includes one or more types that are disallowed for cookies: " + ^ PS.toString s); + (cmap, emap) + end + + | _ => (cmap, emap) + + fun checkSins (cmap, _) t = + let + val s = sins cmap t + in + if PS.isEmpty s then + () + else + E.error ("Not allowed to [de]serialize a value involving one or more disallowed types: " ^ PS.toString s) + end + + fun exp (e, s) = + case e of + ECApp ((EFfi ("Basis", "serialize"), _), t) => + (checkSins s t; s) + | ECApp ((EFfi ("Basis", "deserialize"), _), t) => + (checkSins s t; s) + | _ => s + + fun passthrough (_, s) = s in - ignore (foldl (fn ((d, _), (cmap, emap)) => - case d of - DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap) - | DDatatype dts => - (foldl (fn ((_, n, _, xncs), cmap) => - IM.insert (cmap, n, foldl (fn ((_, _, co), s) => - case co of - NONE => s - | SOME c => PS.union (s, sins cmap c)) - PS.empty xncs)) cmap dts, - emap) - - | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag))) - | DValRec vis => (cmap, - foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag))) - emap vis) - - | DExport (_, n, _) => - (case IM.find (emap, n) of - NONE => raise Fail "MarshalCheck: Unknown export" - | SOME (t, tag) => - let - fun makeS (t, _) = - case t of - TFun (dom, ran) => - (case #1 dom of - CFfi ("Basis", "postBody") => makeS ran - | CApp ((CFfi ("Basis", "option"), _), (CFfi ("Basis", "queryString"), _)) => makeS ran - | _ => PS.union (sins cmap dom, makeS ran)) - | _ => PS.empty - val s = makeS t - in - if PS.isEmpty s then - () - else - E.error ("Input to exported function '" - ^ tag ^ "' involves one or more types that are disallowed for page handler inputs: " - ^ PS.toString s); - (cmap, emap) - end) - - | DCookie (_, _, t, tag) => - let - val s = sins cmap t - in - if PS.isEmpty s then - () - else - E.error ("Cookie '" ^ tag ^ "' includes one or more types that are disallowed for cookies: " - ^ PS.toString s); - (cmap, emap) - end - - | _ => (cmap, emap)) - (IM.empty, IM.empty) file) + ignore (U.File.fold {kind = passthrough, + con = passthrough, + exp = exp, + decl = decl} + (IM.empty, IM.empty) file) end end diff --git a/src/mod_db.sig b/src/mod_db.sig index 8f78f2c2..fb396603 100644 --- a/src/mod_db.sig +++ b/src/mod_db.sig @@ -30,12 +30,15 @@ signature MOD_DB = sig val reset : unit -> unit - val insert : Elab.decl * Time.time -> unit + val insert : Elab.decl * Time.time * bool (* hasErrors *) -> unit (* Here's a declaration, including the modification timestamp of the file it came from. * We might invalidate other declarations that depend on this one, if the timestamp has changed. *) val lookup : Source.decl -> Elab.decl option + val lookupModAndDepsIncludingErrored: + string -> (Elab.decl * Elab.decl list) option + (* Allow undoing to snapshots after failed compilations. *) val snapshot : unit -> unit val revert : unit -> unit diff --git a/src/mod_db.sml b/src/mod_db.sml index 2d6b285b..c821a0bb 100644 --- a/src/mod_db.sml +++ b/src/mod_db.sml @@ -42,7 +42,9 @@ structure IM = IntBinaryMap type oneMod = {Decl : decl, When : Time.time, - Deps : SS.set} + Deps : SS.set, + HasErrors: bool (* We're saving modules with errors so tooling can find them *) + } val byName = ref (SM.empty : oneMod SM.map) val byId = ref (IM.empty : string IM.map) @@ -50,7 +52,39 @@ val byId = ref (IM.empty : string IM.map) fun reset () = (byName := SM.empty; byId := IM.empty) -fun insert (d, tm) = +(* For debug purposes *) +fun printByName (bn: oneMod SM.map): unit = + (TextIO.print ("Contents of ModDb.byName: \n"); + List.app (fn tup => + let + val name = #1 tup + val m = #2 tup + val renderedDeps = + String.concatWith ", " (SS.listItems (#Deps m)) + val renderedMod = + " " ^ name + ^ ". Stored at : " ^ Time.toString (#When m) + ^", HasErrors: " ^ Bool.toString (#HasErrors m) + ^". Deps: " ^ renderedDeps ^"\n" + in + TextIO.print renderedMod + end) + (SM.listItemsi bn)) + +fun dContainsUndeterminedUnif d = + ElabUtil.Decl.exists + {kind = fn _ => false, + con = fn _ => false, + exp = fn e => case e of + EUnif (ref NONE) => true + | _ => false, + sgn_item = fn _ => false, + sgn = fn _ => false, + str = fn _ => false, + decl = fn _ => false} + d + +fun insert (d, tm, hasErrors) = let val xn = case #1 d of @@ -62,10 +96,16 @@ fun insert (d, tm) = NONE => () | SOME (x, n) => let + (* Keep module when it's file didn't change and it was OK before *) val skipIt = case SM.find (!byName, x) of NONE => false | SOME r => #When r = tm + andalso not (#HasErrors r) + (* We save results of error'd compiler passes *) + (* so modules that still have undetermined unif variables *) + (* should not be reused since those are unsuccessfully compiled *) + andalso not (dContainsUndeterminedUnif (#Decl r)) in if skipIt then () @@ -73,7 +113,19 @@ fun insert (d, tm) = let fun doMod (n', deps) = case IM.find (!byId, n') of - NONE => deps + NONE => + ( + (* TextIO.print ("MISSED_DEP: " ^ Int.toString n' ^"\n"); *) + deps) + (* raise Fail ("ModDb: Trying to make dep tree but couldn't find module " ^ Int.toString n') *) + (* I feel like this should throw, but the dependency searching algorithm *) + (* is not 100% precise. I encountered problems in json.urs: *) + (* datatype r = Rec of M.t r *) + (* M is the structure passed to the Recursive functor, so this is not an external dependency *) + (* I'm just not sure how to filter these out yet *) + (* I still think this should throw: *) + (* Trying to add a dep for a module but can't find the dep... *) + (* That will always cause a hole in the dependency tree and cause problems down the line *) | SOME x' => SS.union (deps, SS.add (case SM.find (!byName, x') of @@ -118,8 +170,11 @@ fun insert (d, tm) = x, {Decl = d, When = tm, - Deps = deps}); + Deps = deps, + HasErrors = hasErrors + }); byId := IM.insert (!byId, n, x) + (* printByName (!byName) *) end end end @@ -130,7 +185,7 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) @@ -138,12 +193,26 @@ fun lookup (d : Source.decl) = (case SM.find (!byName, x) of NONE => NONE | SOME r => - if tm = #When r then + if tm = #When r andalso not (#HasErrors r) andalso not (dContainsUndeterminedUnif (#Decl r)) then SOME (#Decl r) else NONE) | _ => NONE +fun lookupModAndDepsIncludingErrored name = + case SM.find (!byName, name) of + NONE => NONE + | SOME m => + let + val deps = SS.listItems (#Deps m) + (* Clumsy way of adding Basis and Top without adding doubles *) + val deps = List.filter (fn x => x <> "Basis" andalso x <> "Top") deps + val deps = ["Basis", "Top"] @ deps + val foundDepModules = List.mapPartial (fn d => SM.find (!byName, d)) deps + in + SOME (#Decl m, List.map (fn a => #Decl a) foundDepModules) + end + val byNameBackup = ref (!byName) val byIdBackup = ref (!byId) 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_fooify.sml b/src/mono_fooify.sml index e64207cd..9cb14400 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -165,12 +165,12 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = end | _ => case t of - TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) else raise CantPass (fm, tAll)) - | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TRecord ((x, t) :: xts) => let val (se, fm) = fooify fm ((EField (e, x), loc), t) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 40b865b0..7e737e44 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -66,9 +66,9 @@ val htmlifyString = String.translate (fn #"<" => "<" fun htmlifySpecialChar ch = "&#" ^ Int.toString (ord ch) ^ ";" -fun hexIt ch = +fun hexPad c = let - val s = Int.fmt StringCvt.HEX (ord ch) + val s = Int.fmt StringCvt.HEX c in case size s of 0 => "00" @@ -76,6 +76,54 @@ fun hexIt ch = | _ => s end +fun rsh a b = + Int.fromLarge (IntInf.~>>(IntInf.fromInt a, Word.fromInt b)) + +fun orb a b = + Int.fromLarge (IntInf.orb(IntInf.fromInt a, IntInf.fromInt b)) + +fun andb a b = + Int.fromLarge (IntInf.andb(IntInf.fromInt a, IntInf.fromInt b)) + + +fun hexIt ch = + let + val c = ord ch + in + if (c <= 0x7f) then + hexPad c + else + ((if (c <= 0x7fff) then + hexPad (orb (rsh c 6) 0xc0) + else + (if (c <= 0xffff) then + hexPad (orb (rsh c 12) 0xe0) + else + hexPad (orb (rsh c 18) 0xf0) + ^ hexPad (orb (andb (rsh c 12) 0x3f) 0x80) + ) + ^ hexPad (orb (andb (rsh c 6) 0x3f) 0x80)) + ) ^ hexPad (orb (andb c 0x3f) 0x80) + end + +fun urlifyCharAux ch = + case ch of + #" " => "+" + | _ => + if ord ch = 0 then + "_" + else + if Char.isAlphaNum ch then + str ch + else + "." ^ hexIt ch + +fun urlifyChar c = + case c of + #"_" => "_" ^ urlifyCharAux c + | _ => urlifyCharAux c + + fun urlifyString s = case s of "" => "_" @@ -84,11 +132,7 @@ fun urlifyString s = "_" else "") - ^ String.translate (fn #" " => "+" - | ch => if Char.isAlphaNum ch then - str ch - else - "." ^ hexIt ch) s + ^ String.translate urlifyCharAux s fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int) @@ -117,7 +161,7 @@ fun unAs s = doChars (String.explode s, []) end -fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s +fun checkUrl s = CharVector.all Char.isGraph s andalso (s = "#" orelse Settings.checkUrl s) val checkData = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #"-") @@ -349,6 +393,13 @@ fun exp e = | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => EFfiApp ("Basis", "urlifyString_w", [e]) + | EFfiApp ("Basis", "urlifyChar", [((EPrim (Prim.Char c), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyChar c)) + | EWrite (EFfiApp ("Basis", "urlifyChar", [((EPrim (Prim.Char c), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyChar c)), loc) + | EWrite (EFfiApp ("Basis", "urlifyChar", [e]), _) => + EFfiApp ("Basis", "urlifyChar_w", [e]) + | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => EPrim (Prim.String (Prim.Normal, "1")) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => 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 11c6ea31..22b4e0e7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -50,6 +50,38 @@ 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 := []; uses_similar := false) + +fun addPrefix prefix = + let + fun isPrefix s1 s2 = + String.isPrefix s1 s2 + andalso (size s1 = size s2 + orelse String.sub (s2, size s1) = #"/") + in + if List.exists (fn prefix' => + let + fun tryOne prefix' prefix = + isPrefix prefix' prefix + andalso (ErrorMsg.error ("Conflicting URL prefixes for page handlers: \"" ^ prefix' ^ "\" is a prefix of \"" ^ prefix ^ "\"."); + true) + in + tryOne prefix' prefix + orelse tryOne prefix prefix' + end) (!url_prefixes) then + () + else + url_prefixes := prefix :: !url_prefixes + end + +end + val nextPvar = MonoFooify.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) val pvarDefs = MonoFooify.pvarDefs @@ -325,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"), _), _), _), _), _), _), _), _) => @@ -1339,7 +1373,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique)))), loc), @@ -1383,7 +1417,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique) ^ ")"), @@ -1540,17 +1574,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.Error), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.Error), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => let + val string = (L'.TFfi ("Basis", "string"), loc) val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (e, L'.None), loc), + ((L'.ECase (e, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [], loc)), + ((L'.PVar ("cmd", string), loc), + (L'.EDml ((L'.ERel 0, loc), L'.None), loc))], + {disc = string, + result = (L'.TRecord [], loc)}), loc), fm) end @@ -1579,7 +1627,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => (case monoType env (L.TRecord changed, loc) of - (L'.TRecord changed, _) => + (L'.TRecord [], _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val rt = (L'.TRecord [], loc) + in + ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e", s, s, + str ""), loc)), loc)), loc), + fm) + end + | (L'.TRecord changed, _) => let val s = (L'.TFfi ("Basis", "string"), loc) val changed = map (fn (x, _) => (x, s)) changed @@ -2638,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 ( @@ -3953,6 +4046,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedToString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "unsafeSerializedFromString"), _), _) => + let + val t = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("v", t, t, (L'.ERel 0, loc)), loc), + fm) + end | L.EFfiApp ("Basis", "url", [(e, _)]) => let @@ -4194,6 +4301,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = | L.DExport (ek, n, b) => let val (_, t, _, s) = Env.lookupENamed env n + val () = addPrefix s fun unwind (t, args) = case #1 t of @@ -4353,6 +4461,7 @@ datatype expungable = Client | Channel fun monoize env file = let + val () = reset () val () = pvars := RM.empty (* Calculate which exported functions need cookie signature protection *) @@ -4522,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) @@ -4546,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 e7cad84e..74954c0f 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1602,14 +1602,17 @@ val () = addDbms {name = "mysql", textKeysNeedLengths = true, supportsNextval = false, supportsNestedPrepared = false, - sqlPrefix = "SET storage_engine=InnoDB;\n\n", + sqlPrefix = "", supportsOctetLength = true, trueString = "TRUE", falseString = "FALSE", onlyUnion = true, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = true, supportsIsDistinctFrom = true, - supportsSHA512 = false} + supportsSHA512 = SOME {InitializeDb = "", + GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}, + supportsSimilar = NONE} end diff --git a/src/postgres.sml b/src/postgres.sml index 2b6bee8c..3e53ed77 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1153,8 +1153,11 @@ val () = addDbms {name = "postgres", onlyUnion = false, nestedRelops = true, windowFunctions = true, + requiresTimestampDefaults = false, supportsIsDistinctFrom = true, - supportsSHA512 = true} + 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/prefix.cm b/src/prefix.cm index 2e71d073..eab0bf71 100644 --- a/src/prefix.cm +++ b/src/prefix.cm @@ -4,4 +4,6 @@ $/basis.cm $/smlnj-lib.cm $smlnj/ml-yacc/ml-yacc-lib.cm $/pp-lib.cm +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.dummy.sml diff --git a/src/prefix.mlb b/src/prefix.mlb index 6a510481..13122fcf 100644 --- a/src/prefix.mlb +++ b/src/prefix.mlb @@ -3,5 +3,8 @@ local $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb $(SML_LIB)/smlnj-lib/PP/pp-lib.mlb + $(SML_LIB)/basis/mlton.mlb + $(SRC)/bg_thread.sig + $(SRC)/bg_thread.mlton.sml in 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/search.sig b/src/search.sig index ac867146..2de85425 100644 --- a/src/search.sig +++ b/src/search.sig @@ -59,4 +59,9 @@ signature SEARCH = sig * ('state11 -> 'state2 -> ('state11 * 'state2, 'abort) result) -> (('state11 * 'state12) * 'state2, 'abort) result + val bindPWithPos : + (('state11 * 'state12) * 'state2, 'abort) result + * (('state11 * 'state12) -> 'state2 -> ('state11 * 'state2, 'abort) result) + -> (('state11 * 'state12) * 'state2, 'abort) result + end diff --git a/src/search.sml b/src/search.sml index 563496fe..5e4e135f 100644 --- a/src/search.sml +++ b/src/search.sml @@ -70,4 +70,12 @@ fun bindP (r, f) = ((x', pos), acc')) | Return x => Return x +fun bindPWithPos (r, f) = + case r of + Continue ((x, pos), acc) => + map (f (x, pos) acc, + fn (x', acc') => + ((x', pos), acc')) + | Return x => Return x + end diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..6a409cdd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,8 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuIncludes : string ref + val configIcuLibs : string ref val libUr : unit -> string val libC : unit -> string @@ -219,8 +221,14 @@ signature SETTINGS = sig onlyUnion : bool, nestedRelops : bool, windowFunctions : bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : {InitializeDb : string, + 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 @@ -236,6 +244,9 @@ signature SETTINGS = sig val setSql : string option -> unit val getSql : unit -> string option + val setEndpoints : string option -> unit + val getEndpoints : unit -> string option + val setCoreInline : int -> unit val getCoreInline : unit -> int @@ -258,6 +269,7 @@ signature SETTINGS = sig val getFileCache : unit -> string option (* Which GET-able functions should be allowed to have side effects? *) + val setSafeGetDefault : bool -> unit val setSafeGets : string list -> unit val isSafeGet : string -> bool diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..eeaf8145 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,7 +32,8 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp - +val configIcuIncludes = ref Config.icuIncludes +val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler fun getCCompiler () = !configCCompiler @@ -116,6 +117,7 @@ fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x) val clientToServerBase = basis ["int", "float", "string", + "char", "time", "file", "unit", @@ -156,6 +158,7 @@ fun isEffectful ("Sqlcache", _) = true fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", + "getenv", "new_client_source", "get_client_source", "set_client_source", @@ -275,6 +278,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("urlifyFloat", "ts"), ("urlifyTime", "ts"), ("urlifyString", "uf"), + ("urlifyChar", "uf"), ("urlifyBool", "ub"), ("recv", "rv"), ("strcat", "cat"), @@ -321,8 +325,10 @@ val jsFuncsBase = basisM [("alert", "alert"), ("ord", "ord"), ("checkUrl", "checkUrl"), + ("anchorUrl", "anchorUrl"), ("bless", "bless"), ("blessData", "blessData"), + ("currentUrl", "currentUrl"), ("eq_time", "eq"), ("lt_time", "lt"), @@ -646,8 +652,10 @@ type dbms = { onlyUnion : bool, nestedRelops : bool, windowFunctions: bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option, + supportsSimilar : {InitializeDb : string} option } val dbmses = ref ([] : dbms list) @@ -680,8 +688,10 @@ val curDb = ref ({name = "", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} : dbms) + supportsSHA512 = NONE, + supportsSimilar = NONE} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = @@ -702,6 +712,10 @@ val sql = ref (NONE : string option) fun setSql so = sql := so fun getSql () = !sql +val endpoints = ref (NONE : string option) +fun setEndpoints so = endpoints := so +fun getEndpoints () = !endpoints + val coreInline = ref 5 fun setCoreInline n = coreInline := n fun getCoreInline () = !coreInline @@ -728,7 +742,8 @@ fun getSigFile () = !sigFile val fileCache = ref (NONE : string option) fun setFileCache v = - (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then + (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true + | SOME _ => false) then ErrorMsg.error "The selected database engine is incompatible with file caching." else (); @@ -740,9 +755,11 @@ structure SS = BinarySetFn(struct val compare = String.compare end) +val safeGetDefault = ref false val safeGet = ref SS.empty +fun setSafeGetDefault b = safeGetDefault := b fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) -fun isSafeGet x = SS.member (!safeGet, x) +fun isSafeGet x = !safeGetDefault orelse SS.member (!safeGet, x) val onError = ref (NONE : (string * string list * string) option) fun setOnError x = onError := x @@ -1003,6 +1020,7 @@ fun reset () = dbstring := NONE; exe := NONE; sql := NONE; + endpoints := NONE; coreInline := 5; monoInline := 5; staticLinking := false; diff --git a/src/sources b/src/sources index 5c0b2a84..74171365 100644 --- a/src/sources +++ b/src/sources @@ -69,6 +69,9 @@ $(SRC)/elab.sml $(SRC)/elab_util.sig $(SRC)/elab_util.sml +$(SRC)/elab_util_pos.sig +$(SRC)/elab_util_pos.sml + $(SRC)/elab_env.sig $(SRC)/elab_env.sml @@ -165,6 +168,9 @@ $(SRC)/css.sml $(SRC)/mono.sml +$(SRC)/endpoints.sig +$(SRC)/endpoints.sml + $(SRC)/mono_util.sig $(SRC)/mono_util.sml @@ -268,6 +274,20 @@ $(SRC)/checknest.sml $(SRC)/compiler.sig $(SRC)/compiler.sml +$(SRC)/getinfo.sig +$(SRC)/getinfo.sml + +$(SRC)/json.sig +$(SRC)/json.sml + +$(SRC)/fromjson.sig +$(SRC)/fromjson.sml + +$(SRC)/lspspec.sml + +$(SRC)/lsp.sig +$(SRC)/lsp.sml + $(SRC)/demo.sig $(SRC)/demo.sml diff --git a/src/specialize.sml b/src/specialize.sml index 33545250..70e646e3 100644 --- a/src/specialize.sml +++ b/src/specialize.sml @@ -44,6 +44,7 @@ end structure CM = BinaryMapFn(CK) structure IM = IntBinaryMap +structure IS = IntBinarySet type datatyp' = { name : int, @@ -61,7 +62,7 @@ type state = { count : int, datatypes : datatyp IM.map, constructors : int IM.map, - decls : (string * int * string list * (string * int * con option) list) list + decls : (string * int * string list * (string * int * con option) list) list } fun kind (k, st) = (k, st) @@ -72,6 +73,12 @@ val isOpen = U.Con.exists {kind = fn _ => false, CRel _ => true | _ => false} +fun findApp (c, args) = + case c of + CApp ((c', _), arg) => findApp (c', arg :: args) + | CNamed n => SOME (n, args) + | _ => NONE + fun considerSpecialization (st : state, n, args, dt : datatyp) = let val args = map ReduceLocal.reduceCon args @@ -132,31 +139,20 @@ fun considerSpecialization (st : state, n, args, dt : datatyp) = end and con (c, st : state) = - let - fun findApp (c, args) = - case c of - CApp ((c', _), arg) => findApp (c', arg :: args) - | CNamed n => SOME (n, args) - | _ => NONE - in - case findApp (c, []) of - SOME (n, args as (_ :: _)) => - if List.exists isOpen args then - (c, st) - else - (case IM.find (#datatypes st, n) of - NONE => (c, st) - | SOME dt => - if length args <> #params dt then - (c, st) - else - let - val (n, _, st) = considerSpecialization (st, n, args, dt) - in - (CNamed n, st) - end) - | _ => (c, st) - end + case findApp (c, []) of + SOME (n, args as ((_, loc) :: _)) => + (case IM.find (#datatypes st, n) of + NONE => (c, st) + | SOME dt => + if length args <> #params dt then + (c, st) + else + let + val (n, _, st) = considerSpecialization (st, n, args, dt) + in + (CNamed n, st) + end) + | _ => (c, st) and specCon st = U.Con.foldMap {kind = kind, con = con} st @@ -252,6 +248,48 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} fun specialize file = let + (*val () = CorePrint.debug := true + val () = print "SPECIALIZING\n"*) + + (* Let's run around a file, finding any polymorphic uses of a datatype. + * However, don't count polymorphism within a datatype's own definition! + * To that end, we run a silly transform on the file before traversing. *) + val file' = + map (fn d => + case #1 d of + DDatatype dts => + U.Decl.map {kind = fn x => x, + exp = fn x => x, + decl = fn x => x, + con = fn CNamed n => + if List.exists (fn (_, n', _, _) => n' = n) dts then + CUnit + else + CNamed n + | c => c} d + | _ => d) file + + val fancyDatatypes = U.File.fold {kind = fn (_, fd) => fd, + exp = fn (_, fd) => fd, + decl = fn (_, fd) => fd, + con = fn (c, fd) => + case c of + CApp (c1, c2) => + if isOpen c2 then + case findApp (c, []) of + SOME (n, _) => + ((*Print.preface ("Disqualifier", + CorePrint.p_con CoreEnv.empty (c, ErrorMsg.dummySpan));*) + IS.add (fd, n)) + | NONE => fd + else + fd + | _ => fd} + IS.empty file' + + (* Why did we find the polymorphism? + * It would be incoherent to specialize a datatype used polymorphically. *) + fun doDecl (d, st) = let (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*) @@ -259,23 +297,27 @@ fun specialize file = in case #1 d of DDatatype dts => - ((case #decls st of - [] => [d] - | dts' => [(DDatatype (dts' @ dts), #2 d)]), - {count = #count st, - datatypes = foldl (fn ((x, n, xs, xnts), dts) => - IM.insert (dts, n, - {name = x, - params = length xs, - constructors = xnts, - specializations = CM.empty})) - (#datatypes st) dts, - constructors = foldl (fn ((x, n, xs, xnts), cs) => - foldl (fn ((_, n', _), constructors) => - IM.insert (constructors, n', n)) + if List.exists (fn (_, n, _, _) => IS.member (fancyDatatypes, n)) dts then + ((*Print.preface ("Skipping", CorePrint.p_decl CoreEnv.empty d);*) + ([d], st)) + else + ((case #decls st of + [] => [d] + | dts' => [(DDatatype (dts' @ dts), #2 d)]), + {count = #count st, + datatypes = foldl (fn ((x, n, xs, xnts), dts) => + IM.insert (dts, n, + {name = x, + params = length xs, + constructors = xnts, + specializations = CM.empty})) + (#datatypes st) dts, + constructors = foldl (fn ((x, n, xs, xnts), cs) => + foldl (fn ((_, n', _), constructors) => + IM.insert (constructors, n', n)) cs xnts) - (#constructors st) dts, - decls = []}) + (#constructors st) dts, + decls = []}) | _ => (case #decls st of [] => [d] @@ -287,10 +329,10 @@ fun specialize file = end val (ds, _) = ListUtil.foldlMapConcat doDecl - {count = U.File.maxName file + 1, - datatypes = IM.empty, - constructors = IM.empty, - decls = []} file + {count = U.File.maxName file + 1, + datatypes = IM.empty, + constructors = IM.empty, + decls = []} file in ds end diff --git a/src/sqlite.sml b/src/sqlite.sml index db7052d1..0e97bf69 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -855,7 +855,9 @@ val () = addDbms {name = "sqlite", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} + supportsSHA512 = NONE, + supportsSimilar = NONE} end diff --git a/src/tag.sml b/src/tag.sml index 94e5d44f..3040c36c 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -124,7 +124,7 @@ fun exp uf env (e, s) = () else ErrorMsg.errorAt loc - ("Duplicate HTTP tag " + ("Duplicate URL prefix " ^ s); if ek = ek' then () 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/src/urweb.lex b/src/urweb.lex index 368b9f1b..23c32ea1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -174,7 +174,7 @@ fun unescape loc s = %% %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); %full -%s COMMENT STRING CHAR XML XMLTAG; +%s COMMENT XMLCOMMENT STRING CHAR XML XMLTAG; id = [a-z_][A-Za-z0-9_']*; xmlid = [A-Za-z][A-Za-z0-9_-]*; @@ -184,13 +184,12 @@ intconst = [0-9]+; realconst = [0-9]+\.[0-9]*; hexconst = 0x[0-9A-F]+; notags = ([^<{\n(]|(\([^\*<{\n]))+; -xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; xint = x[0-9a-fA-F][0-9a-fA-F]; %% -<INITIAL,COMMENT,XMLTAG> +<INITIAL,COMMENT,XMLTAG,XMLCOMMENT> \n => (newline yypos; continue ()); <XML> \n => (newline yypos; @@ -219,7 +218,9 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <COMMENT> "*)" => (exitComment (); continue ()); -<XML> "<!--" {xcom} "-->" => (continue ()); +<XML> "<!--" => (YYBEGIN XMLCOMMENT; continue ()); +<XMLCOMMENT> "-->" => (YYBEGIN XML; continue ()); +<XMLCOMMENT> . => (continue ()); <STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); <STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); |