diff options
Diffstat (limited to 'src')
208 files changed, 70667 insertions, 0 deletions
diff --git a/src/c/Makefile.am b/src/c/Makefile.am new file mode 100644 index 0000000..f4d9bef --- /dev/null +++ b/src/c/Makefile.am @@ -0,0 +1,21 @@ +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_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_CFLAGS = -Wimplicit -Wall -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) +liburweb_http_la_LIBADD = liburweb.la +liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_cgi_la_LIBADD = liburweb.la +liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_fastcgi_la_LIBADD = liburweb.la +liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' +liburweb_static_la_LIBADD = liburweb.la +liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' diff --git a/src/c/cgi.c b/src/c/cgi.c new file mode 100644 index 0000000..d060532 --- /dev/null +++ b/src/c/cgi.c @@ -0,0 +1,149 @@ +#include "config.h" + +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> +#include <string.h> +#include <stdlib.h> +#include <unistd.h> +#include <stdarg.h> + +#include "urweb.h" +#include "request.h" + +extern uw_app uw_application; + +static char *uppercased; +static size_t uppercased_len; + +static char *get_header(void *data, const char *h) { + size_t len = strlen(h); + char *s, *r; + const char *saved_h = h; + + if (len > uppercased_len) { + uppercased_len = len; + uppercased = realloc(uppercased, len + 6); + } + + strcpy(uppercased, "HTTP_"); + for (s = uppercased+5; *h; ++h) + *s++ = *h == '-' ? '_' : toupper((int)*h); + *s = 0; + + if ((r = getenv(uppercased))) + return r; + else if (!strcasecmp(saved_h, "Content-length") + || !strcasecmp(saved_h, "Content-type")) + return getenv(uppercased + 5); + else + return NULL; +} + +static char *get_env(void *data, const char *name) { + return getenv(name); +} + +static void on_success(uw_context ctx) { } + +static void on_failure(uw_context ctx) { + uw_write_header(ctx, "Status: 500 Internal Server Error\r\n"); +} + +static void log_error(void *data, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vfprintf(stderr, fmt, ap); +} + +static void log_debug(void *data, const char *fmt, ...) { +} + +static uw_loggers ls = {NULL, log_error, log_debug}; + +int main(int argc, char *argv[]) { + uw_context ctx = uw_request_new_context(0, &uw_application, &ls); + uw_request_context rc = uw_new_request_context(); + request_result rr; + char *method = getenv("REQUEST_METHOD"), + *path = getenv("SCRIPT_NAME"), *path_info = getenv("PATH_INFO"), + *query_string = getenv("QUERY_STRING"); + char *body = malloc(1); + ssize_t body_len = 1, body_pos = 0, res; + + uppercased = malloc(6); + + if (!method) { + log_error(NULL, "REQUEST_METHOD not set\n"); + exit(1); + } + + if (!path) { + log_error(NULL, "SCRIPT_NAME not set\n"); + exit(1); + } + + if (path_info) { + char *new_path = malloc(strlen(path) + strlen(path_info) + 1); + sprintf(new_path, "%s%s", path, path_info); + path = new_path; + } + + if (!query_string) + query_string = ""; + + while ((res = read(0, body + body_pos, body_len - body_pos)) > 0) { + body_pos += res; + + if (body_pos == body_len) { + body_len *= 2; + body = realloc(body, body_len); + } + } + + if (res < 0) { + log_error(NULL, "Error reading stdin\n"); + exit(1); + } + + uw_set_on_success(""); + uw_set_headers(ctx, get_header, NULL); + uw_set_env(ctx, get_env, NULL); + uw_request_init(&uw_application, &ls); + + body[body_pos] = 0; + rr = uw_request(rc, ctx, method, path, query_string, body, body_pos, + on_success, on_failure, + NULL, log_error, log_debug, + -1, NULL, NULL); + uw_print(ctx, 1); + + if (rr == SERVED) + return 0; + else + return 1; +} + +void *uw_init_client_data() { + return NULL; +} + +void uw_free_client_data(void *data) { +} + +void uw_copy_client_data(void *dst, void *src) { +} + +void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + uw_ensure_transaction(ctx); + uw_get_app(ctx)->expunger(ctx, cli); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); +} + +void uw_post_expunge(uw_context ctx, void *data) { +} + +int uw_supports_direct_status = 0; diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c new file mode 100644 index 0000000..c37debf --- /dev/null +++ b/src/c/fastcgi.c @@ -0,0 +1,693 @@ +#include "config.h" + +#include <assert.h> +#include <stdint.h> +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <netdb.h> +#include <netinet/in.h> +#include <unistd.h> +#include <signal.h> +#include <stdarg.h> +#include <ctype.h> + +#include <pthread.h> + +#include "urweb.h" +#include "request.h" +#include "queue.h" + +#include "fastcgi.h" + +#define THREAD_LOCAL __thread + +extern uw_app uw_application; + +typedef struct { + unsigned char version; + unsigned char type; + unsigned char requestIdB1; + unsigned char requestIdB0; + unsigned char contentLengthB1; + unsigned char contentLengthB0; + unsigned char paddingLength; + unsigned char reserved; + unsigned char contentData[65535]; +} FCGI_Record; + +typedef struct { + FCGI_Record r; + int sock; +} FCGI_Output; + +typedef struct { + FCGI_Record r; + int available, used, sock; +} FCGI_Input; + +// The FastCGI request ID corresponding to the request being handled by the +// current worker thread. (Each worker thread can only handle one request at a +// time.) +static THREAD_LOCAL int current_request_id; + +// Reads the FastCGI request ID from a FastCGI record. The result is guaranteed +// to be in the range [0, 2^16); this function returns an int to avoid C type +// promotion insanity. +static int fastcgi_request_id(const FCGI_Record* const r) { + const int requestid = r->requestIdB1 << 8 | r->requestIdB0; + assert(requestid >= 0); + assert(requestid <= UINT16_MAX); + return requestid; +} + +static FCGI_Output *fastcgi_output() { + FCGI_Output *o = malloc(sizeof(FCGI_Output)); + + o->r.version = FCGI_VERSION_1; + o->r.paddingLength = 0; + o->r.reserved = 0; + + return o; +} + +static FCGI_Input *fastcgi_input() { + FCGI_Input *i = malloc(sizeof(FCGI_Input)); + + i->available = i->used = 0; + + return i; +} + +static void fastcgi_input_reset(FCGI_Input *i) { + i->available = i->used = 0; +} + +static int fastcgi_send(FCGI_Output *o, + unsigned char type, + unsigned short contentLength) { + o->r.type = type; + assert(current_request_id <= UINT16_MAX); + o->r.requestIdB1 = current_request_id >> 8; + o->r.requestIdB0 = current_request_id & 0x000000ff; + o->r.contentLengthB1 = contentLength >> 8; + o->r.contentLengthB0 = contentLength & 255; + return uw_really_send(o->sock, &o->r, sizeof(o->r) - 65535 + contentLength); +} + +static FCGI_Record *fastcgi_recv(FCGI_Input *i) { + if (i->used > 0) { + memmove((void*)&i->r, (void*)&i->r + i->used, i->available - i->used); + i->available -= i->used; + i->used = 0; + } + + while (1) { + ssize_t n; + + if (i->available >= sizeof(FCGI_Record) - 65535 + && i->available >= sizeof(FCGI_Record) - 65535 + + ((i->r.contentLengthB1 << 8) | i->r.contentLengthB0) + + i->r.paddingLength) { + i->used = sizeof(FCGI_Record) - 65535 + + ((i->r.contentLengthB1 << 8) | i->r.contentLengthB0) + + i->r.paddingLength; + + return &i->r; + } + + n = recv(i->sock, (void*)&i->r + i->available, sizeof(i->r) - i->available, 0); + + if (n <= 0) + return NULL; + + i->available += n; + } +} + +static void on_success(uw_context ctx) { } + +static void on_failure(uw_context ctx) { + uw_write_header(ctx, "Status: 500 Internal Server Error\r\n"); +} + +static int write_stdout(void *data, const char *buf, size_t len) { + FCGI_Output *o = (FCGI_Output *)data; + while (len > 0) { + size_t len2 = len; + if (len2 > 65535) + len2 = 65535; + memcpy(o->r.contentData, buf, len2); + if (fastcgi_send(o, FCGI_STDOUT, len2)) { + fprintf(stderr, "fastcgi_send() failed in write_stdout().\n"); + return -1; + } + buf += len2; + len -= len2; + } + + return 0; +} + +#include <errno.h> + +static void write_stderr(FCGI_Output *o, const char *fmt, ...) { + int len; + va_list ap; + va_start(ap, fmt); + + len = vsnprintf((char *)o->r.contentData, 65535, fmt, ap); + if (len < 0) + fprintf(stderr, "vsnprintf() failed in write_stderr().\n"); + else if (fastcgi_send(o, FCGI_STDERR, len)) + fprintf(stderr, "fastcgi_send() failed in write_stderr().\n"); +} + +static void close_stream(FCGI_Output *o, unsigned char type) { + if (fastcgi_send(o, type, 0)) + fprintf(stderr, "fastcgi_send() failed in close_stream().\n"); +} + +static void log_error(void *data, const char *fmt, ...) { + FCGI_Output *o = (FCGI_Output *)data; + va_list ap; + va_start(ap, fmt); + + if (o) { + int len = vsnprintf((char *)o->r.contentData, 65535, fmt, ap); + if (len < 0) + fprintf(stderr, "vsnprintf() failed in log_error().\n"); + else if (fastcgi_send(o, FCGI_STDERR, len)) + fprintf(stderr, "fastcgi_send() failed in log_error().\n"); + } else + vfprintf(stderr, fmt, ap); +} + +static void log_debug(void *data, const char *fmt, ...) { + FCGI_Output *o = (FCGI_Output *)data; + va_list ap; + va_start(ap, fmt); + + if (o) { + strcpy((char *)o->r.contentData, "DEBUG: "); + int len = vsnprintf((char *)o->r.contentData + 7, 65535 - 7, fmt, ap); + if (len < 0) + fprintf(stderr, "vsnprintf() failed in log_debug().\n"); + else if (fastcgi_send(o, FCGI_STDERR, len + 7)) { + len += 7; + if (len >= 65535) len = 65534; + o->r.contentData[len] = 0; + fputs((char *)o->r.contentData, stderr); + fflush(stderr); + } + } else + vfprintf(stderr, fmt, ap); +} + +typedef struct { + char *name, *value; + unsigned name_len, value_len; +} nvp; + +static char *search_nvps(nvp *nvps, const char *h) { + for (; nvps->name[0]; ++nvps) + if (!strcmp(h, nvps->name)) + return nvps->value; + + return NULL; +} + +typedef struct { + nvp *nvps; + char *uppercased; + int n_nvps, uppercased_len; +} headers; + +static char *get_header(void *data, const char *h) { + headers *hs = (headers *)data; + size_t len = strlen(h); + char *s; + const char *saved_h = h; + + if (len > hs->uppercased_len) { + hs->uppercased_len = len; + hs->uppercased = realloc(hs->uppercased, len + 6); + } + + strcpy(hs->uppercased, "HTTP_"); + for (s = hs->uppercased+5; *h; ++h) + *s++ = *h == '-' ? '_' : toupper((int)*h); + *s = 0; + + if (!strcasecmp(saved_h, "Content-length") + || !strcasecmp(saved_h, "Content-type")) { + if ((s = search_nvps(hs->nvps, hs->uppercased + 5))) + return s; + } + + return search_nvps(hs->nvps, hs->uppercased); +} + +static char *get_env(void *data, const char *h) { + headers *hs = (headers *)data; + + return search_nvps(hs->nvps, h); +} + +static int read_funny_len(unsigned char **buf, int *len) { + if (*len <= 0) + return -1; + + if ((*buf)[0] >> 7 == 0) { + int r = (*buf)[0]; + ++*buf; + --*len; + return r; + } + else if (*len < 4) + return -1; + else { + int r = (((*buf)[0] & 0x7f) << 24) + ((*buf)[1] << 16) + ((*buf)[2] << 8) + (*buf)[3]; + *buf += 4; + *len -= 4; + return r; + } +} + +static int read_nvp(unsigned char **buf, int len, nvp *nv) { + int nameLength, valueLength; + + if ((nameLength = read_funny_len(buf, &len)) < 0) + return -1; + if ((valueLength = read_funny_len(buf, &len)) < 0) + return -2; + if (len < nameLength + valueLength) + return -3; + + if (nameLength+1 > nv->name_len) { + nv->name_len = nameLength+1; + nv->name = realloc(nv->name, nv->name_len); + } + if (valueLength+1 > nv->value_len) { + nv->value_len = valueLength+1; + nv->value = realloc(nv->value, nv->value_len); + } + + memcpy(nv->name, *buf, nameLength); + nv->name[nameLength] = 0; + + memcpy(nv->value, *buf + nameLength, valueLength); + nv->value[valueLength] = 0; + + *buf += nameLength + valueLength; + + return 0; +} + +static int fastcgi_close_with(FCGI_Output *out, request_result rr) { + FCGI_EndRequestBody *erb = (FCGI_EndRequestBody *)out->r.contentData; + + close_stream(out, FCGI_STDOUT); + close_stream(out, FCGI_STDERR); + + if (rr == SERVED) + erb->appStatusB3 = erb->appStatusB2 = erb->appStatusB1 = erb->appStatusB0 = 0; + else + erb->appStatusB3 = erb->appStatusB2 = erb->appStatusB1 = erb->appStatusB0 = 0xFF; + + erb->protocolStatus = FCGI_REQUEST_COMPLETE; + fastcgi_send(out, FCGI_END_REQUEST, sizeof(FCGI_EndRequestBody)); + return close(out->sock); +} + +static int fastcgi_close(int sock) { + FCGI_Output out; + out.sock = sock; + out.r.version = FCGI_VERSION_1; + out.r.paddingLength = 0; + out.r.reserved = 0; + + return fastcgi_close_with(&out, SERVED); +} + +int fastcgi_send_normal(int sock, const void *buf, ssize_t len) { + FCGI_Output out; + out.sock = sock; + out.r.version = FCGI_VERSION_1; + out.r.paddingLength = 0; + out.r.reserved = 0; + + return write_stdout(&out, buf, len); +} + +static void *worker(void *data) { + FCGI_Input *in = fastcgi_input(); + FCGI_Output *out = fastcgi_output(); + uw_loggers ls = {out, log_error, log_debug}; + uw_context ctx = uw_request_new_context(*(int *)data, &uw_application, &ls); + uw_request_context rc = uw_new_request_context(); + headers hs; + size_t body_size = 0; + char *body = malloc(0); + size_t path_size = 0; + char *path_buf = malloc(0); + + hs.uppercased = malloc(6); + hs.uppercased_len = 0; + hs.nvps = malloc(sizeof(nvp)); + hs.n_nvps = 1; + hs.nvps[0].name = malloc(1); + hs.nvps[0].name_len = 1; + hs.nvps[0].value = malloc(0); + hs.nvps[0].value_len = 0; + + while (1) { + FCGI_Record *r; + size_t used_nvps = 0; + int body_len, body_read; + char *s; + char *method, *path, *path_info, *query_string; + + in->sock = out->sock = uw_dequeue(); + + if (!(r = fastcgi_recv(in))) { + fprintf(stderr, "Error receiving initial message\n"); + goto done; + } + + // Save the FastCGI request ID this worker is handling so that fastcgi_send + // can include it in its response. + current_request_id = fastcgi_request_id(r); + + if (r->type != FCGI_BEGIN_REQUEST) { + write_stderr(out, "First message is not BEGIN_REQUEST\n"); + goto done; + } else if (r->contentData[1] != FCGI_RESPONDER) { + write_stderr(out, "Request is for a role besides RESPONDER\n"); + goto done; + } + + while (1) { + unsigned char *buf; + int len; + + if (!(r = fastcgi_recv(in))) { + write_stderr(out, "Error receiving environment variables\n"); + goto done; + } + + if (fastcgi_request_id(r) != current_request_id) { + write_stderr(out, + "Ignoring environment variables for request %d (current" + " request has id %d)\n", + fastcgi_request_id(r), + current_request_id); + continue; + } + + if (r->type != FCGI_PARAMS) { + write_stderr(out, "Expected FCGI_PARAMS but got %d\n", r->type); + goto done; + } + + if (r->contentLengthB1 == 0 && r->contentLengthB0 == 0) + break; + + len = (r->contentLengthB1 << 8) | r->contentLengthB0; + + for (buf = r->contentData; buf < r->contentData + len; ) { + if (used_nvps == hs.n_nvps-1) { + ++hs.n_nvps; + hs.nvps = realloc(hs.nvps, hs.n_nvps * sizeof(nvp)); + hs.nvps[hs.n_nvps-1].name = malloc(1); + hs.nvps[hs.n_nvps-1].value = malloc(0); + hs.nvps[hs.n_nvps-1].name_len = 1; + hs.nvps[hs.n_nvps-1].value_len = 0; + } + + if (read_nvp(&buf, len - (buf - r->contentData), &hs.nvps[used_nvps]) < 0) { + write_stderr(out, "Error reading FCGI_PARAMS name-value pair\n"); + goto done; + } + + //write_stderr(out, "PARAM: %s -> %s\n", hs.nvps[used_nvps].name, hs.nvps[used_nvps].value); + + ++used_nvps; + } + } + + hs.nvps[used_nvps].name[0] = 0; + + if ((s = get_header(&hs, "Content-Length"))) { + body_len = atoi(s); + if (body_len < 0) { + write_stderr(out, "Invalid Content-Length\n"); + goto done; + } + } else + body_len = 0; + + if (body_len+1 > body_size) { + body_size = body_len+1; + body = realloc(body, body_size); + } + + for (body_read = 0; body_read < body_len; ) { + int this_len; + + if (!(r = fastcgi_recv(in))) { + write_stderr(out, "Error receiving STDIN\n"); + goto done; + } + + if (fastcgi_request_id(r) != current_request_id) { + write_stderr(out, + "Ignoring STDIN for request %d (current request has id" + " %d)\n", + fastcgi_request_id(r), + current_request_id); + continue; + } + + if (r->type != FCGI_STDIN) { + write_stderr(out, "Expected FCGI_STDIN but got %d\n", r->type); + goto done; + } + + if (r->contentLengthB1 == 0 && r->contentLengthB0 == 0) { + write_stderr(out, "End of STDIN\n"); + break; + } + + this_len = (r->contentLengthB1 << 8) | r->contentLengthB0; + + if (body_read + this_len > body_len) { + write_stderr(out, "Too much STDIN\n"); + goto done; + } + + memcpy(&body[body_read], r->contentData, this_len); + body_read += this_len; + } + + body[body_read] = 0; + + if (!(method = search_nvps(hs.nvps, "REQUEST_METHOD"))) { + write_stderr(out, "REQUEST_METHOD not set\n"); + goto done; + } + + if (!(path = search_nvps(hs.nvps, "SCRIPT_NAME"))) { + write_stderr(out, "SCRIPT_NAME not set\n"); + goto done; + } + + if ((path_info = search_nvps(hs.nvps, "PATH_INFO"))) { + int len1 = strlen(path), len2 = strlen(path_info); + int len = len1 + len2 + 1; + + if (len > path_size) { + path_size = len; + path_buf = realloc(path_buf, path_size); + } + + sprintf(path_buf, "%s%s", path, path_info); + path = path_buf; + } + + if (!(query_string = search_nvps(hs.nvps, "QUERY_STRING"))) + query_string = ""; + + uw_set_headers(ctx, get_header, &hs); + uw_set_env(ctx, get_env, &hs); + + { + request_result rr; + + rr = uw_request(rc, ctx, method, path, query_string, body, body_read, + on_success, on_failure, + out, log_error, log_debug, + in->sock, fastcgi_send_normal, fastcgi_close); + + if (rr == KEEP_OPEN) + goto done2; + + uw_output(ctx, write_stdout, out); + fastcgi_close_with(out, rr); + goto done2; + } + + done: + close(in->sock); + done2: + fastcgi_input_reset(in); + uw_reset(ctx); + } + + return NULL; +} + +static void help(char *cmd) { + printf("Usage: %s [-t <thread-count>]\n", cmd); +} + +static void sigint(int signum) { + printf("Exiting....\n"); + exit(0); +} + +static uw_loggers ls = {NULL, log_error, log_debug}; + +int main(int argc, char *argv[]) { + // The skeleton for this function comes from Beej's sockets tutorial. + struct sockaddr_in their_addr; // connector's address information + socklen_t sin_size; + int nthreads = 1, i, *names, opt; + char *fwsa = getenv("FCGI_WEB_SERVER_ADDRS"), *nthreads_s = getenv("URWEB_NUM_THREADS"); + + if (nthreads_s) { + nthreads = atoi(nthreads_s); + if (nthreads <= 0) { + fprintf(stderr, "Bad URWEB_NUM_THREADS value\n"); + return 1; + } + } + + signal(SIGINT, sigint); + signal(SIGPIPE, SIG_IGN); + signal(SIGUSR1, sigint); + signal(SIGTERM, sigint); + + while ((opt = getopt(argc, argv, "ht:")) != -1) { + switch (opt) { + case '?': + fprintf(stderr, "Unknown command-line option"); + help(argv[0]); + return 1; + + case 'h': + help(argv[0]); + return 0; + + case 't': + nthreads = atoi(optarg); + if (nthreads <= 0) { + fprintf(stderr, "Invalid thread count\n"); + help(argv[0]); + return 1; + } + break; + + default: + fprintf(stderr, "Unexpected getopt() behavior\n"); + return 1; + } + } + + uw_set_on_success(""); + uw_request_init(&uw_application, &ls); + + names = calloc(nthreads, sizeof(int)); + + sin_size = sizeof their_addr; + + { + pthread_t thread; + + pruner_data *pd = (pruner_data *)malloc(sizeof(pruner_data)); + pd->app = &uw_application; + pd->loggers = &ls; + + if (pthread_create_big(&thread, NULL, client_pruner, pd)) { + fprintf(stderr, "Error creating pruner thread\n"); + return 1; + } + } + + for (i = 0; i < nthreads; ++i) { + pthread_t thread; + names[i] = i; + if (pthread_create_big(&thread, NULL, worker, &names[i])) { + fprintf(stderr, "Error creating worker thread #%d\n", i); + return 1; + } + } + + while (1) { + int new_fd = accept(FCGI_LISTENSOCK_FILENO, (struct sockaddr *)&their_addr, &sin_size); + + if (new_fd < 0) { + fprintf(stderr, "Socket accept failed\n"); + return 1; + } + + if (fwsa) { + char host[100], matched = 0; + char *ips, *sep; + + if (getnameinfo((struct sockaddr *)&their_addr, sin_size, host, sizeof host, NULL, 0, NI_NUMERICHOST)) { + fprintf(stderr, "Remote IP determination failed\n"); + return 1; + } + + for (ips = fwsa; (sep = strchr(ips, ',')); ips = sep+1) { + if (!strncmp(ips, host, sep - ips)) { + matched = 1; + break; + } + } + + if (!matched && strcmp(ips, host)) { + fprintf(stderr, "Remote address is not in FCGI_WEB_SERVER_ADDRS"); + return 1; + } + } + + uw_enqueue(new_fd); + } +} + +void *uw_init_client_data() { + return NULL; +} + +void uw_free_client_data(void *data) { +} + +void uw_copy_client_data(void *dst, void *src) { +} + +void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + uw_ensure_transaction(ctx); + uw_get_app(ctx)->expunger(ctx, cli); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); +} + +void uw_post_expunge(uw_context ctx, void *data) { +} + +int uw_supports_direct_status = 0; diff --git a/src/c/fastcgi.h b/src/c/fastcgi.h new file mode 100644 index 0000000..826d808 --- /dev/null +++ b/src/c/fastcgi.h @@ -0,0 +1,113 @@ +// This code comes from the FastCGI 1.0 spec at: +// http://www.fastcgi.com/drupal/node/6?q=node/22 + +/* + * Listening socket file number + */ +#define FCGI_LISTENSOCK_FILENO 0 + +typedef struct { + unsigned char version; + unsigned char type; + unsigned char requestIdB1; + unsigned char requestIdB0; + unsigned char contentLengthB1; + unsigned char contentLengthB0; + unsigned char paddingLength; + unsigned char reserved; +} FCGI_Header; + +/* + * Number of bytes in a FCGI_Header. Future versions of the protocol + * will not reduce this number. + */ +#define FCGI_HEADER_LEN 8 + +/* + * Value for version component of FCGI_Header + */ +#define FCGI_VERSION_1 1 + +/* + * Values for type component of FCGI_Header + */ +#define FCGI_BEGIN_REQUEST 1 +#define FCGI_ABORT_REQUEST 2 +#define FCGI_END_REQUEST 3 +#define FCGI_PARAMS 4 +#define FCGI_STDIN 5 +#define FCGI_STDOUT 6 +#define FCGI_STDERR 7 +#define FCGI_DATA 8 +#define FCGI_GET_VALUES 9 +#define FCGI_GET_VALUES_RESULT 10 +#define FCGI_UNKNOWN_TYPE 11 +#define FCGI_MAXTYPE (FCGI_UNKNOWN_TYPE) + +/* + * Value for requestId component of FCGI_Header + */ +#define FCGI_NULL_REQUEST_ID 0 + +typedef struct { + unsigned char roleB1; + unsigned char roleB0; + unsigned char flags; + unsigned char reserved[5]; +} FCGI_BeginRequestBody; + +typedef struct { + FCGI_Header header; + FCGI_BeginRequestBody body; +} FCGI_BeginRequestRecord; + +/* + * Mask for flags component of FCGI_BeginRequestBody + */ +#define FCGI_KEEP_CONN 1 + +/* + * Values for role component of FCGI_BeginRequestBody + */ +#define FCGI_RESPONDER 1 +#define FCGI_AUTHORIZER 2 +#define FCGI_FILTER 3 + +typedef struct { + unsigned char appStatusB3; + unsigned char appStatusB2; + unsigned char appStatusB1; + unsigned char appStatusB0; + unsigned char protocolStatus; + unsigned char reserved[3]; +} FCGI_EndRequestBody; + +typedef struct { + FCGI_Header header; + FCGI_EndRequestBody body; +} FCGI_EndRequestRecord; + +/* + * Values for protocolStatus component of FCGI_EndRequestBody + */ +#define FCGI_REQUEST_COMPLETE 0 +#define FCGI_CANT_MPX_CONN 1 +#define FCGI_OVERLOADED 2 +#define FCGI_UNKNOWN_ROLE 3 + +/* + * Variable names for FCGI_GET_VALUES / FCGI_GET_VALUES_RESULT records + */ +#define FCGI_MAX_CONNS "FCGI_MAX_CONNS" +#define FCGI_MAX_REQS "FCGI_MAX_REQS" +#define FCGI_MPXS_CONNS "FCGI_MPXS_CONNS" + +typedef struct { + unsigned char type; + unsigned char reserved[7]; +} FCGI_UnknownTypeBody; + +typedef struct { + FCGI_Header header; + FCGI_UnknownTypeBody body; +} FCGI_UnknownTypeRecord; diff --git a/src/c/http.c b/src/c/http.c new file mode 100644 index 0000000..21ad809 --- /dev/null +++ b/src/c/http.c @@ -0,0 +1,561 @@ +#include "config.h" + +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <netinet/tcp.h> +#include <arpa/inet.h> +#include <unistd.h> +#include <signal.h> +#include <stdarg.h> + +#include <pthread.h> + +#include "urweb.h" +#include "request.h" +#include "queue.h" + +extern uw_app uw_application; + +int uw_backlog = SOMAXCONN; +static int keepalive = 0, quiet = 0; + +#define qfprintf(f, fmt, args...) do { if(!quiet) fprintf(f, fmt, ##args); } while(0) +#define qprintf(fmt, args...) do { if(!quiet) printf(fmt, ##args); } while(0) + +static char *get_header(void *data, const char *h) { + char *s = data; + int len = strlen(h); + char *p; + + while ((p = strchr(s, ':'))) { + if (p - s == len && !strncasecmp(s, h, len)) { + return p + 2; + } else { + if ((s = strchr(p, 0)) && s[1] != 0) + s += 2; + else + return NULL; + } + } + + return NULL; +} + +static char *get_env(void *data, const char *name) { + return getenv(name); +} + +static void on_success(uw_context ctx) { + uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); +} + +static void on_failure(uw_context ctx) { + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\r\n"); +} + +static void log_error(void *data, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vfprintf(stderr, fmt, ap); +} + +static void log_debug(void *data, const char *fmt, ...) { + if (!quiet) { + va_list ap; + va_start(ap, fmt); + + vprintf(fmt, ap); + } +} + +static uw_loggers ls = {NULL, log_error, log_debug}; + +static unsigned max_buf_size = 1024 * 1024; // That's 1MB. + +static void *worker(void *data) { + int me = *(int *)data; + uw_context ctx = uw_request_new_context(me, &uw_application, &ls); + size_t buf_size = 1024; + char *buf = malloc(buf_size), *back = buf; + uw_request_context rc = uw_new_request_context(); + int sock = 0; + + while (1) { + if (sock == 0) { + back = buf; + sock = uw_dequeue(); + } + + uw_set_remoteSock(ctx, sock); + + qprintf("Handling connection with thread #%d.\n", me); + + while (1) { + int r; + char *method, *path, *query_string, *headers, *body, *after, *s, *s2; + + if (back - buf == buf_size - 1) { + char *new_buf; + size_t new_buf_size = buf_size*2; + if (new_buf_size > max_buf_size) { + qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size); + close(sock); + sock = 0; + break; + } + new_buf = realloc(buf, new_buf_size); + if(!new_buf) { + qfprintf(stderr, "Realloc failed while receiving header\n"); + close(sock); + sock = 0; + break; + } + buf_size = new_buf_size; + back = new_buf + (back - buf); + buf = new_buf; + } + + *back = 0; + body = strstr(buf, "\r\n\r\n"); + if (body == NULL) { + r = recv(sock, back, buf_size - 1 - (back - buf), 0); + + if (r < 0) { + qfprintf(stderr, "Recv failed while receiving header, retcode %d errno %m\n", r); + close(sock); + sock = 0; + break; + } + + if (r == 0) { + qprintf("Connection closed.\n"); + close(sock); + sock = 0; + break; + } + + back += r; + *back = 0; + } + + if (body != NULL || (body = strstr(buf, "\r\n\r\n"))) { + request_result rr; + int should_keepalive = 0; + + body[0] = body[1] = 0; + body += 4; + + if ((s = strcasestr(buf, "\r\nContent-Length: ")) && s < body) { + int clen; + + if (sscanf(s + 18, "%d\r\n", &clen) != 1) { + fprintf(stderr, "Malformed Content-Length header\n"); + close(sock); + sock = 0; + break; + } + + while (back - body < clen) { + if (back - buf == buf_size - 1) { + char *new_buf; + size_t new_buf_size = buf_size * 2; + if (new_buf_size > max_buf_size) { + qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size); + close(sock); + sock = 0; + break; + } + new_buf = realloc(buf, new_buf_size); + if(!new_buf) { + qfprintf(stderr, "Realloc failed while receiving content\n"); + close(sock); + sock = 0; + goto done; + } + + buf_size = new_buf_size; + back = new_buf + (back - buf); + body = new_buf + (body - buf); + s = new_buf + (s - buf); + + buf = new_buf; + } + + r = recv(sock, back, buf_size - 1 - (back - buf), 0); + + if (r < 0) { + qfprintf(stderr, "Recv failed while receiving content, retcode %d errno %m\n", r); + close(sock); + sock = 0; + goto done; + } + + if (r == 0) { + qfprintf(stderr, "Connection closed.\n"); + close(sock); + sock = 0; + goto done; + } + + back += r; + *back = 0; + } + + after = body + clen; + } else + after = body; + + body[-4] = '\r'; + body[-3] = '\n'; + + if (!(s = strstr(buf, "\r\n"))) { + fprintf(stderr, "No newline in request\n"); + close(sock); + sock = 0; + goto done; + } + + body[-4] = body[-3] = 0; + + *s = 0; + headers = s + 2; + method = s = buf; + + strsep(&s, " "); + if (!s) { + fprintf(stderr, "No first space in HTTP command\n"); + close(sock); + sock = 0; + goto done; + } + path = s; + + if ((s = strchr(path, ' '))) + *s = 0; + + if ((s = strchr(path, '?'))) { + *s = 0; + query_string = s+1; + } + else + query_string = NULL; + + s = headers; + while ((s2 = strchr(s, '\r'))) { + if (s2 == s) { + *s = 0; + break; + } + + s = s2; + + if (s[1] == 0) + break; + + *s = 0; + s += 2; + } + + uw_set_headers(ctx, get_header, headers); + uw_set_env(ctx, get_env, NULL); + + qprintf("Serving URI %s....\n", path); + rr = uw_request(rc, ctx, method, path, query_string, body, back - body, + on_success, on_failure, + NULL, log_error, log_debug, + sock, uw_really_send, close); + + if (rr != KEEP_OPEN) { + if (keepalive) { + char *connection = uw_Basis_requestHeader(ctx, "Connection"); + + should_keepalive = !(connection && !strcmp(connection, "close")); + } + + if (!should_keepalive) + uw_write_header(ctx, "Connection: close\r\n"); + + if (!uw_has_contentLength(ctx)) { + char clen[100]; + + sprintf(clen, "Content-length: %d\r\n", uw_pagelen(ctx)); + uw_write_header(ctx, clen); + } + + uw_send(ctx, sock); + } + + if (rr == SERVED || rr == FAILED) { + if (should_keepalive) { + // In case any other requests are queued up, shift + // unprocessed part of buffer to front. + int kept = back - after; + + if (kept == 0) { + // No pipelining going on here. + // We'd might as well try to switch to a different connection, + // while we wait for more input on this one. + uw_enqueue(sock); + sock = 0; + } else { + // More input! Move it to the front and continue in this loop. + memmove(buf, after, kept); + back = buf + kept; + } + } else { + close(sock); + sock = 0; + } + } else if (rr == KEEP_OPEN) + sock = 0; + else + fprintf(stderr, "Illegal uw_request return code: %d\n", rr); + + break; + } + } + + done: + uw_reset(ctx); + } + + return NULL; +} + +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); +} + +static void sigint(int signum) { + printf("Exiting....\n"); + exit(0); +} + +union uw_sockaddr { + struct sockaddr sa; + struct sockaddr_in ipv4; + struct sockaddr_in6 ipv6; +}; + +int main(int argc, char *argv[]) { + // The skeleton for this function comes from Beej's sockets tutorial. + int sockfd; // listen on sock_fd + union uw_sockaddr my_addr; + union uw_sockaddr their_addr; // connector's address information + socklen_t my_size = 0, sin_size; + int yes = 1, uw_port = 8080, nthreads = 1, i, *names, opt; + int recv_timeout_sec = 5; + + signal(SIGINT, sigint); + signal(SIGPIPE, SIG_IGN); + + // default if not specified: IPv4 with my IP + memset(&my_addr, 0, sizeof my_addr); + 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) { + switch (opt) { + case '?': + fprintf(stderr, "Unknown command-line option\n"); + help(argv[0]); + return 1; + + case 'h': + help(argv[0]); + return 0; + + case 'p': + uw_port = atoi(optarg); + if (uw_port <= 0) { + fprintf(stderr, "Invalid port number\n"); + help(argv[0]); + return 1; + } + break; + + case 'a': + my_addr.sa.sa_family = AF_INET; + if (!inet_pton(AF_INET, optarg, &my_addr.ipv4.sin_addr)) { + fprintf(stderr, "Invalid IPv4 address\n"); + help(argv[0]); + return 1; + } + break; + + case 'A': + my_addr.sa.sa_family = AF_INET6; + if (!inet_pton(AF_INET6, optarg, &my_addr.ipv6.sin6_addr)) { + fprintf(stderr, "Invalid IPv6 address\n"); + help(argv[0]); + return 1; + } + break; + + case 't': + nthreads = atoi(optarg); + if (nthreads <= 0) { + fprintf(stderr, "Invalid thread count\n"); + help(argv[0]); + return 1; + } + break; + + case 'k': + keepalive = 1; + break; + + case 'T': + recv_timeout_sec = atoi(optarg); + if (recv_timeout_sec < 0) { + fprintf(stderr, "Invalid recv timeout\n"); + help(argv[0]); + return 1; + } + break; + + case 'q': + quiet = 1; + break; + + case 'm': + opt = atoi(optarg); + if (opt <= 0) { + fprintf(stderr, "Invalid maximum buffer size\n"); + help(argv[0]); + return 1; + } + max_buf_size = opt; + break; + + default: + fprintf(stderr, "Unexpected getopt() behavior\n"); + return 1; + } + } + + uw_request_init(&uw_application, &ls); + + names = calloc(nthreads, sizeof(int)); + + sockfd = socket(my_addr.sa.sa_family, SOCK_STREAM, 0); // do some error checking! + + if (sockfd < 0) { + fprintf(stderr, "Listener socket creation failed\n"); + return 1; + } + + if (setsockopt(sockfd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) { + fprintf(stderr, "Listener socket option setting failed\n"); + return 1; + } + + switch (my_addr.sa.sa_family) + { + case AF_INET: + my_size = sizeof(my_addr.ipv4); + my_addr.ipv4.sin_port = htons(uw_port); + break; + + case AF_INET6: + my_size = sizeof(my_addr.ipv6); + my_addr.ipv6.sin6_port = htons(uw_port); + break; + } + + if (bind(sockfd, &my_addr.sa, my_size) < 0) { + fprintf(stderr, "Listener socket bind failed\n"); + return 1; + } + + if (listen(sockfd, uw_backlog) < 0) { + fprintf(stderr, "Socket listen failed\n"); + return 1; + } + + sin_size = sizeof their_addr; + + qprintf("Starting the Ur/Web native HTTP server, which is intended for use\n" + "ONLY DURING DEVELOPMENT. You probably want to use one of the other backends,\n" + "behind a production-quality HTTP server, for a real deployment.\n\n"); + + qprintf("Listening on port %d....\n", uw_port); + + { + pthread_t thread; + + pruner_data *pd = (pruner_data *)malloc(sizeof(pruner_data)); + pd->app = &uw_application; + pd->loggers = &ls; + + if (pthread_create_big(&thread, NULL, client_pruner, pd)) { + fprintf(stderr, "Error creating pruner thread\n"); + return 1; + } + } + + for (i = 0; i < nthreads; ++i) { + pthread_t thread; + names[i] = i; + if (pthread_create_big(&thread, NULL, worker, &names[i])) { + fprintf(stderr, "Error creating worker thread #%d\n", i); + return 1; + } + } + + while (1) { + int new_fd = accept(sockfd, &their_addr.sa, &sin_size); + + if (new_fd < 0) { + qfprintf(stderr, "Socket accept failed\n"); + } else { + qprintf("Accepted connection.\n"); + + if (keepalive) { + int flag = 1; + setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); + } + + if(recv_timeout_sec>0) { + int ret; + struct timeval tv; + memset(&tv, 0, sizeof(struct timeval)); + tv.tv_sec = recv_timeout_sec; + ret = setsockopt(new_fd, SOL_SOCKET, SO_RCVTIMEO, (char *)&tv, sizeof(struct timeval)); + if(ret != 0) { + qfprintf(stderr, "Timeout setting failed, errcode %d errno '%m'\n", ret); + } + } + + uw_enqueue(new_fd); + } + } +} + +void *uw_init_client_data() { + return NULL; +} + +void uw_free_client_data(void *data) { +} + +void uw_copy_client_data(void *dst, void *src) { +} + +void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + uw_ensure_transaction(ctx); + uw_get_app(ctx)->expunger(ctx, cli); + + if (uw_commit(ctx)) + uw_error(ctx, UNLIMITED_RETRY, "Rerunning expunge transaction"); +} + +void uw_post_expunge(uw_context ctx, void *data) { +} + +int uw_supports_direct_status = 1; diff --git a/src/c/memmem.c b/src/c/memmem.c new file mode 100644 index 0000000..f31f4e3 --- /dev/null +++ b/src/c/memmem.c @@ -0,0 +1,87 @@ +#include "config.h" + +/* $NetBSD$ */ + +/*- + * Copyright (c) 2003 The NetBSD Foundation, Inc. + * All rights reserved. + * + * This code is derived from software contributed to The NetBSD Foundation + * by + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. 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. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * This product includes software developed by the NetBSD + * Foundation, Inc. and its contributors. + * 4. Neither the name of The NetBSD Foundation nor the names of its + * contributors may be used to endorse or promote products derived + * from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE NETBSD FOUNDATION, INC. 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 FOUNDATION 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. + */ + +// Function renamed by Adam Chlipala in 2016. + +#include <sys/cdefs.h> +#if defined(LIBC_SCCS) && !defined(lint) +__RCSID("$NetBSD$"); +#endif /* LIBC_SCCS and not lint */ + +#if !defined(_KERNEL) && !defined(_STANDALONE) +#include <assert.h> +#include <string.h> +#else +#include <lib/libkern/libkern.h> +#define _DIAGASSERT(x) (void)0 +#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) +{ + /* Sanity check */ + if(!(b1 != NULL && b2 != NULL && len1 != 0 && len2 != 0)) + return NULL; + + /* Initialize search pointer */ + char *sp = (char *) b1; + + /* Initialize pattern pointer */ + char *pp = (char *) b2; + + /* Intialize end of search address space pointer */ + char *eos = sp + len1 - len2; + + while (sp <= eos) { + if (*sp == *pp) + if (memcmp(sp, pp, len2) == 0) + return sp; + + sp++; + } + + return NULL; +} diff --git a/src/c/openssl.c b/src/c/openssl.c new file mode 100644 index 0000000..5982b83 --- /dev/null +++ b/src/c/openssl.c @@ -0,0 +1,139 @@ +#include "config.h" + +#include <stdlib.h> +#include <unistd.h> +#include <sys/types.h> +#include <sys/stat.h> +#include <fcntl.h> +#include <stdio.h> +#include <string.h> + +#include <openssl/opensslv.h> +#include <openssl/sha.h> +#include <openssl/rand.h> + +#define PASSSIZE 4 + +int uw_hash_blocksize = 32; + +static int password[PASSSIZE]; + +char *uw_sig_file = NULL; + +static void random_password() { + if (!RAND_bytes((unsigned char *)password, sizeof password)) { + fprintf(stderr, "Error generating random password\n"); + perror("RAND_bytes"); + exit(1); + } +} + +#if OPENSSL_VERSION_NUMBER < 0x10100000L +// We're using OpenSSL <1.1, so we need to specify threading callbacks. See +// threads(3SSL). + +#include <assert.h> +#include <pthread.h> + +#include <openssl/crypto.h> + +static pthread_mutex_t *openssl_locks; + +// OpenSSL callbacks +#ifdef PTHREAD_T_IS_POINTER +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_pointer(result, pthread_self()); +} +#else +static void thread_id(CRYPTO_THREADID *const result) { + CRYPTO_THREADID_set_numeric(result, (unsigned long)pthread_self()); +} +#endif + +static void lock_or_unlock(const int mode, const int type, const char *file, + const int line) { + pthread_mutex_t *const lock = &openssl_locks[type]; + if (mode & CRYPTO_LOCK) { + if (pthread_mutex_lock(lock)) { + fprintf(stderr, "Can't take lock at %s:%d\n", file, line); + exit(1); + } + } else { + if (pthread_mutex_unlock(lock)) { + fprintf(stderr, "Can't release lock at %s:%d\n", file, line); + exit(1); + } + } +} + +static void init_openssl() { + int i; + // Set up OpenSSL. + assert(openssl_locks == NULL); + openssl_locks = malloc(CRYPTO_num_locks() * sizeof(pthread_mutex_t)); + if (!openssl_locks) { + perror("malloc"); + exit(1); + } + for (i = 0; i < CRYPTO_num_locks(); ++i) { + pthread_mutex_init(&(openssl_locks[i]), NULL); + } + CRYPTO_THREADID_set_callback(thread_id); + CRYPTO_set_locking_callback(lock_or_unlock); +} + +#else +// We're using OpenSSL >=1.1, which is thread-safe by default. We don't need to +// do anything here. + +static void init_openssl() {} + +#endif // OPENSSL_VERSION_NUMBER < 0x10100000L + +void uw_init_crypto() { + init_openssl(); + // Prepare signatures. + if (uw_sig_file) { + int fd; + + if (access(uw_sig_file, F_OK)) { + random_password(); + + if ((fd = open(uw_sig_file, O_WRONLY | O_CREAT, 0700)) < 0) { + fprintf(stderr, "Can't open signature file %s\n", uw_sig_file); + perror("open"); + exit(1); + } + + if (write(fd, &password, sizeof password) != sizeof password) { + fprintf(stderr, "Error writing signature file\n"); + exit(1); + } + + close(fd); + } else { + if ((fd = open(uw_sig_file, O_RDONLY)) < 0) { + fprintf(stderr, "Can't open signature file %s\n", uw_sig_file); + perror("open"); + exit(1); + } + + if (read(fd, &password, sizeof password) != sizeof password) { + fprintf(stderr, "Error reading signature file\n"); + exit(1); + } + + close(fd); + } + } else + random_password(); +} + +void uw_sign(const char *in, unsigned char *out) { + SHA256_CTX c; + + SHA256_Init(&c); + SHA256_Update(&c, password, sizeof password); + SHA256_Update(&c, in, strlen(in)); + SHA256_Final(out, &c); +} diff --git a/src/c/queue.c b/src/c/queue.c new file mode 100644 index 0000000..645f69e --- /dev/null +++ b/src/c/queue.c @@ -0,0 +1,63 @@ +#include "config.h" + +#include <stdlib.h> + +#include <pthread.h> + +typedef struct node { + int fd; + struct node *next; +} *node; + +static node front = NULL, back = NULL; + +static int empty() { + return front == NULL; +} + +static void enqueue(int fd) { + node n = malloc(sizeof(struct node)); + + n->fd = fd; + n->next = NULL; + if (back) + back->next = n; + else + front = n; + back = n; +} + +static int dequeue() { + int ret = front->fd; + node n = front->next; + free(front); + + front = n; + + if (!front) + back = NULL; + + return ret; +} + +static pthread_mutex_t queue_mutex = PTHREAD_MUTEX_INITIALIZER; +static pthread_cond_t queue_cond = PTHREAD_COND_INITIALIZER; + +int uw_dequeue() { + int sock; + + pthread_mutex_lock(&queue_mutex); + while (empty()) + pthread_cond_wait(&queue_cond, &queue_mutex); + sock = dequeue(); + pthread_mutex_unlock(&queue_mutex); + + return sock; +} + +void uw_enqueue(int new_fd) { + pthread_mutex_lock(&queue_mutex); + enqueue(new_fd); + pthread_cond_broadcast(&queue_cond); + pthread_mutex_unlock(&queue_mutex); +} diff --git a/src/c/request.c b/src/c/request.c new file mode 100644 index 0000000..a7f2385 --- /dev/null +++ b/src/c/request.c @@ -0,0 +1,614 @@ +#include "config.h" + +#include <stdio.h> +#include <string.h> +#include <stdlib.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <unistd.h> +#include <signal.h> + +#include <pthread.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); + + if (r) { + log_error(logger_data, "Error running SQL ROLLBACK\n"); + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\r\n"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL ROLLBACK\n"); + uw_set_error_message(ctx, "Database error; you are probably out of storage space."); + } + + return r; +} + +uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls) { + void *logger_data = ls->logger_data; + uw_logger log_debug = ls->log_debug; + uw_logger log_error = ls->log_error; + uw_context ctx = uw_init(id, ls); + int retries_left = MAX_RETRIES; + + if (uw_set_app(ctx, app)) { + log_error(logger_data, "Unable to initialize request context. Most likely the limit on number of form inputs has been exceeded.\n"); + uw_free(ctx); + return NULL; + } + + while (1) { + failure_kind fk = uw_begin_init(ctx); + + if (fk == SUCCESS) { + log_debug(logger_data, "Database connection initialized.\n"); + break; + } else if (fk == BOUNDED_RETRY) { + if (retries_left) { + log_debug(logger_data, "Initialization error triggers bounded retry: %s\n", uw_error_message(ctx)); + --retries_left; + } else { + log_error(logger_data, "Fatal initialization error (out of retries): %s\n", uw_error_message(ctx)); + uw_free(ctx); + return NULL; + } + } else if (fk == UNLIMITED_RETRY) + log_debug(logger_data, "Initialization error triggers unlimited retry: %s\n", uw_error_message(ctx)); + else if (fk == FATAL) { + log_error(logger_data, "Fatal initialization error: %s\n", uw_error_message(ctx)); + uw_free(ctx); + return NULL; + } else { + log_error(logger_data, "Unknown uw_begin_init return code!\n"); + uw_free(ctx); + return NULL; + } + } + + return ctx; +} + +static void *ticker(void *data) { + while (1) { + usleep(100000); + ++uw_time; + } + + return NULL; +} + +typedef struct { + int id; + uw_loggers *ls; + uw_periodic pdic; + uw_app *app; +} periodic; + +static void *periodic_loop(void *data) { + periodic *p = (periodic *)data; + uw_context ctx = uw_request_new_context(p->id, p->app, p->ls); + + if (!ctx) + exit(1); + + while (1) { + int retries_left = MAX_RETRIES; + + failure_kind r; + do { + uw_reset(ctx); + r = uw_runCallback(ctx, p->pdic.callback); + if (r == BOUNDED_RETRY) + --retries_left; + else if (r == UNLIMITED_RETRY) + p->ls->log_debug(p->ls->logger_data, "Error triggers unlimited retry in periodic: %s\n", uw_error_message(ctx)); + else if (r == BOUNDED_RETRY) + p->ls->log_debug(p->ls->logger_data, "Error triggers bounded retry in periodic: %s\n", uw_error_message(ctx)); + else if (r == FATAL) + p->ls->log_error(p->ls->logger_data, "Fatal error: %s\n", uw_error_message(ctx)); + if (r == FATAL || r == BOUNDED_RETRY || r == UNLIMITED_RETRY) + if (try_rollback(ctx, 0, p->ls->logger_data, p->ls->log_error)) + return NULL; + } while (r == UNLIMITED_RETRY || (r == BOUNDED_RETRY && retries_left > 0)); + + if (r != FATAL && r != BOUNDED_RETRY) { + if (uw_commit(ctx)) + r = UNLIMITED_RETRY; + } + + sleep(p->pdic.period); + }; +} + +static unsigned long long stackSize; + +int pthread_create_big(pthread_t *outThread, void *foo, void *threadFunc, void *arg) +{ + if (stackSize > 0) { + int err; + pthread_attr_t stackSizeAttribute; + + err = pthread_attr_init(&stackSizeAttribute); + if (err) return err; + + err = pthread_attr_setstacksize(&stackSizeAttribute, stackSize); + if (err) return err; + + return pthread_create(outThread, &stackSizeAttribute, threadFunc, arg); + } else { + return pthread_create(outThread, NULL, threadFunc, arg); + } +} + +void uw_request_init(uw_app *app, uw_loggers* ls) { + uw_context ctx; + failure_kind fk; + uw_periodic *ps; + int id; + char *stackSize_s; + + uw_logger log_debug = ls->log_debug; + uw_logger log_error = ls->log_error; + void* logger_data = ls->logger_data; + + if ((stackSize_s = getenv("URWEB_STACK_SIZE")) != NULL && stackSize_s[0] != 0) { + stackSize = atoll(stackSize_s); + + if (stackSize <= 0) { + fprintf(stderr, "Invalid stack size \"%s\"\n", stackSize_s); + exit(1); + } + } + + uw_global_init(); + uw_app_init(app); + + { + pthread_t thread; + + if (uw_time_max && pthread_create_big(&thread, NULL, ticker, NULL)) { + fprintf(stderr, "Error creating ticker thread\n"); + exit(1); + } + } + + ctx = uw_request_new_context(0, app, ls); + + if (!ctx) + exit(1); + + for (fk = uw_initialize(ctx); fk == UNLIMITED_RETRY; fk = uw_initialize(ctx)) { + log_debug(logger_data, "Unlimited retry during init: %s\n", uw_error_message(ctx)); + uw_rollback(ctx, 1); + uw_reset(ctx); + } + + if (fk != SUCCESS) { + log_error(logger_data, "Failed to initialize database! %s\n", uw_error_message(ctx)); + uw_rollback(ctx, 0); + exit(1); + } + + uw_free(ctx); + + id = 1; + for (ps = app->periodics; ps->callback; ++ps) { + pthread_t thread; + periodic *arg = malloc(sizeof(periodic)); + arg->id = id++; + arg->ls = ls; + arg->pdic = *ps; + arg->app = app; + + if (pthread_create_big(&thread, NULL, periodic_loop, arg)) { + fprintf(stderr, "Error creating periodic thread\n"); + exit(1); + } + } +} + + +struct uw_rc { + size_t path_copy_size, queryString_size; + char *path_copy, *queryString; +}; + +uw_request_context uw_new_request_context(void) { + uw_request_context r = malloc(sizeof(struct uw_rc)); + r->path_copy_size = 0; + r->queryString_size = 1; + r->path_copy = malloc(0); + r->queryString = malloc(1); + return r; +} + +void uw_free_request_context(uw_request_context r) { + free(r->path_copy); + free(r->queryString); + free(r); +} + +request_result uw_request(uw_request_context rc, uw_context ctx, + char *method, char *path, char *query_string, + char *body, size_t body_len, + void (*on_success)(uw_context), void (*on_failure)(uw_context), + void *logger_data, uw_logger log_error, uw_logger log_debug, + int sock, + int (*send)(int sockfd, const void *buf, ssize_t len), + int (*close)(int fd)) { + int retries_left = MAX_RETRIES; + failure_kind fk; + int is_post = 0; + char *boundary = NULL; + size_t boundary_len = 0; + char *inputs; + const char *prefix = uw_get_url_prefix(ctx); + char *s; + int had_error = 0, is_fancy = 0; + char errmsg[ERROR_BUF_LEN]; + + uw_reset(ctx); + + rc->queryString[0] = 0; + + for (s = path; *s; ++s) { + if (s[0] == '%' && s[1] == '2' && s[2] == '7') { + s[0] = '\''; + memmove(s+1, s+3, strlen(s+3)+1); + } + } + + uw_set_currentUrl(ctx, path); + + if (!strcmp(method, "POST")) { + char *clen_s = uw_Basis_requestHeader(ctx, "Content-length"); + if (!clen_s) { + clen_s = "0"; + /*log_error(logger_data, "No Content-length with POST\n"); + return FAILED;*/ + } + int clen = atoi(clen_s); + if (clen < 0) { + log_error(logger_data, "Negative Content-length with POST\n"); + return FAILED; + } + + if (body_len < clen) { + log_error(logger_data, "Request doesn't contain all POST data (according to Content-Length)\n"); + return FAILED; + } + + is_post = 1; + uw_isPost(ctx); + + clen_s = uw_Basis_requestHeader(ctx, "Content-type"); + + if (!clen_s || strcasecmp(clen_s, "application/x-www-form-urlencoded")) + is_fancy = 1; + + if (clen_s && !strncasecmp(clen_s, "multipart/form-data", 19)) { + if (strncasecmp(clen_s + 19, "; boundary=", 11)) { + log_error(logger_data, "Bad multipart boundary spec"); + return FAILED; + } + + boundary = clen_s + 28; + boundary[0] = '-'; + boundary[1] = '-'; + boundary_len = strlen(boundary); + } else if (clen_s) { + uw_Basis_postBody pb = {clen_s, body, body_len}; + uw_postBody(ctx, pb); + } + } else if (strcmp(method, "GET")) { + log_error(logger_data, "Not ready for non-GET/POST command: %s\n", method); + return FAILED; + } + + if (!strncmp(path, prefix, strlen(prefix)) + && !strcmp(path + strlen(prefix), ".msgs")) { + char *id = uw_Basis_requestHeader(ctx, "UrWeb-Client"); + char *pass = uw_Basis_requestHeader(ctx, "UrWeb-Pass"); + + if (sock < 0) { + log_error(logger_data, ".msgs requested, but not socket supplied\n"); + return FAILED; + } + + if (id && pass) { + unsigned idn = atoi(id); + uw_client_connect(idn, atoi(pass), sock, send, close, logger_data, log_error); + log_debug(logger_data, "Processed request for messages by client %u\n\n", idn); + return KEEP_OPEN; + } + else { + log_error(logger_data, "Missing fields in .msgs request: %s, %s\n\n", id, pass); + return FAILED; + } + } + + if (boundary) { + char *part = body, *after_sub_headers, *header, *after_header; + size_t part_len; + + part = strstr(part, boundary); + if (!part) { + log_error(logger_data, "Missing first multipart boundary\n"); + return FAILED; + } + part += boundary_len; + + while (1) { + char *name = NULL, *filename = NULL, *type = NULL; + + if (part[0] == '-' && part[1] == '-') + break; + + if (*part != '\r') { + log_error(logger_data, "No \\r after multipart boundary\n"); + return FAILED; + } + ++part; + if (*part != '\n') { + log_error(logger_data, "No \\n after multipart boundary\n"); + return FAILED; + } + ++part; + + if (!(after_sub_headers = strstr(part, "\r\n\r\n"))) { + log_error(logger_data, "Missing end of headers after multipart boundary\n"); + return FAILED; + } + after_sub_headers[2] = 0; + after_sub_headers += 4; + + for (header = part; (after_header = strstr(header, "\r\n")); header = after_header + 2) { + char *colon, *after_colon; + + *after_header = 0; + if (!(colon = strchr(header, ':'))) { + log_error(logger_data, "Missing colon in multipart sub-header\n"); + return FAILED; + } + *colon++ = 0; + if (*colon++ != ' ') { + log_error(logger_data, "No space after colon in multipart sub-header\n"); + return FAILED; + } + + if (!strcasecmp(header, "Content-Disposition")) { + if (strncmp(colon, "form-data; ", 11)) { + log_error(logger_data, "Multipart data is not \"form-data\"\n"); + return FAILED; + } + + for (colon += 11; (after_colon = strchr(colon, '=')); colon = after_colon) { + char *data; + after_colon[0] = 0; + if (after_colon[1] != '"') { + log_error(logger_data, "Disposition setting is missing initial quote\n"); + return FAILED; + } + data = after_colon+2; + if (!(after_colon = strchr(data, '"'))) { + log_error(logger_data, "Disposition setting is missing final quote\n"); + return FAILED; + } + after_colon[0] = 0; + ++after_colon; + if (after_colon[0] == ';' && after_colon[1] == ' ') + after_colon += 2; + + if (!strcasecmp(colon, "name")) + name = data; + else if (!strcasecmp(colon, "filename")) + filename = data; + } + } else if (!strcasecmp(header, "Content-Type")) { + type = colon; + } + } + + part = urweb_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; + } + part[-2] = 0; + part_len = part - after_sub_headers - 2; + part[0] = 0; + part += boundary_len; + + if (filename) { + uw_Basis_file f = {filename, type, {part_len, after_sub_headers}}; + + if (uw_set_file_input(ctx, name, f)) { + log_error(logger_data, "%s\n", uw_error_message(ctx)); + return FAILED; + } + } else if (uw_set_input(ctx, name, after_sub_headers)) { + log_error(logger_data, "%s\n", uw_error_message(ctx)); + return FAILED; + } + } + } + else if (!is_fancy) { + inputs = is_post ? body : query_string; + + if (inputs) { + char *name, *value; + int len = strlen(inputs); + + if (len+1 > rc->queryString_size) { + char *qs = realloc(rc->queryString, len+1); + if(qs == NULL) { + log_error(logger_data, "queryString is too long (not enough memory)\n"); + return FAILED; + } + rc->queryString = qs; + rc->queryString_size = len+1; + } + strcpy(rc->queryString, inputs); + + while (*inputs) { + name = inputs; + if ((inputs = strchr(inputs, '&'))) + *inputs++ = 0; + else + inputs = strchr(name, 0); + + if ((value = strchr(name, '='))) { + *value++ = 0; + if (uw_set_input(ctx, name, value)) { + log_error(logger_data, "%s\n", uw_error_message(ctx)); + return FAILED; + } + } + else if (uw_set_input(ctx, name, "")) { + log_error(logger_data, "%s\n", uw_error_message(ctx)); + return FAILED; + } + } + } + } + + while (1) { + uw_setQueryString(ctx, rc->queryString); + + if (!had_error) { + size_t path_len = strlen(path); + + on_success(ctx); + + if (path_len + 1 > rc->path_copy_size) { + char *pc = realloc(rc->path_copy, path_len + 1); + if(pc == NULL) { + log_error(logger_data, "Path is too long (not enough memory)\n"); + return FAILED; + } + rc->path_copy = pc; + rc->path_copy_size = path_len + 1; + } + strcpy(rc->path_copy, path); + + uw_set_deadline(ctx, uw_time + uw_time_max); + fk = uw_begin(ctx, rc->path_copy); + } else { + uw_set_deadline(ctx, uw_time + uw_time_max); + fk = uw_begin_onError(ctx, errmsg); + } + + if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { + uw_commit(ctx); + if (uw_has_error(ctx) && !had_error) { + log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx)); + uw_reset_keep_error_message(ctx); + on_failure(ctx); + + if (uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + try_rollback(ctx, 0, logger_data, log_error); + + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n</body></html>"); + + return FAILED; + } + } else + return had_error ? FAILED : SERVED; + } else if (fk == BOUNDED_RETRY) { + if (retries_left) { + log_debug(logger_data, "Error triggers bounded retry: %s\n", uw_error_message(ctx)); + --retries_left; + } + else { + log_error(logger_data, "Fatal error (out of retries): %s\n", uw_error_message(ctx)); + + if (!had_error && uw_get_app(ctx)->on_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + try_rollback(ctx, 0, logger_data, log_error); + + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Fatal error (out of retries): "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n"); + + return FAILED; + } + } + } else if (fk == UNLIMITED_RETRY) + log_debug(logger_data, "Error triggers unlimited retry: %s\n", uw_error_message(ctx)); + else if (fk == FATAL) { + log_error(logger_data, "Fatal error: %s\n", uw_error_message(ctx)); + + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, uw_error_message(ctx)); + } else { + try_rollback(ctx, 0, logger_data, log_error); + + uw_reset_keep_error_message(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>"); + uw_write(ctx, "Fatal error: "); + uw_write(ctx, uw_error_message(ctx)); + uw_write(ctx, "\n</body></html>"); + + return FAILED; + } + } else { + log_error(logger_data, "Unknown uw_handle return code!\n"); + + if (uw_get_app(ctx)->on_error && !had_error) { + had_error = 1; + strcpy(errmsg, "Unknown uw_handle return code"); + } else { + try_rollback(ctx, 0, logger_data, log_error); + + uw_reset_keep_request(ctx); + on_failure(ctx); + uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write(ctx, "Unknown uw_handle return code!\n"); + + return FAILED; + } + } + + if (try_rollback(ctx, 1, logger_data, log_error)) + return FAILED; + + uw_reset_keep_request(ctx); + } +} + +void *client_pruner(void *data) { + pruner_data *pd = (pruner_data *)data; + uw_context ctx = uw_request_new_context(0, pd->app, pd->loggers); + + if (!ctx) + exit(1); + + while (1) { + uw_prune_clients(ctx); + sleep(5); + } +} diff --git a/src/c/static.c b/src/c/static.c new file mode 100644 index 0000000..d70881e --- /dev/null +++ b/src/c/static.c @@ -0,0 +1,70 @@ +#include "config.h" + +#include <stdio.h> +#include <stdarg.h> + +#include "urweb.h" + +extern uw_app uw_application; + +static void log_(void *data, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vprintf(fmt, ap); +} + +static uw_loggers loggers = {NULL, log_, log_}; + +static char *get_header(void *data, const char *h) { + return NULL; +} + +int main(int argc, char *argv[]) { + uw_context ctx; + failure_kind fk; + + if (argc != 2) { + fprintf(stderr, "Pass exactly one argument: the URI to run\n"); + return 1; + } + + ctx = uw_init(0, &loggers); + uw_set_app(ctx, &uw_application); + uw_set_headers(ctx, get_header, NULL); + uw_initialize(ctx); + + while (1) { + fk = uw_begin(ctx, argv[1]); + + if (fk == SUCCESS || fk == RETURN_INDIRECTLY) { + uw_commit(ctx); + uw_print(ctx, 1); + puts(""); + return 0; + } else if (fk != UNLIMITED_RETRY) { + fprintf(stderr, "Error: %s\n", uw_error_message(ctx)); + return 1; + } + + uw_reset(ctx); + } +} + +void *uw_init_client_data() { + return NULL; +} + +void uw_free_client_data(void *data) { +} + +void uw_copy_client_data(void *dst, void *src) { +} + +void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { +} + +void uw_post_expunge(uw_context ctx, void *data) { +} + +int uw_supports_direct_status = 0; diff --git a/src/c/urweb.c b/src/c/urweb.c new file mode 100644 index 0000000..6f2dde3 --- /dev/null +++ b/src/c/urweb.c @@ -0,0 +1,4980 @@ +#include "config.h" + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include <strings.h> +#include <ctype.h> +#include <setjmp.h> +#include <stdarg.h> +#include <assert.h> +#include <ctype.h> +#include <limits.h> +#include <stdint.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <openssl/des.h> +#include <openssl/rand.h> +#include <time.h> +#include <math.h> + +#include <pthread.h> + +#include "types.h" + +#include "uthash.h" + +uw_unit uw_unit_v = 0; + + +// Socket extras + +int uw_really_send(int sock, const void *buf, ssize_t len) { + while (len > 0) { + ssize_t n = send(sock, buf, len, 0); + + if (n < 0) + return n; + + buf += n; + len -= n; + } + + return 0; +} + +int uw_really_write(int fd, const void *buf, size_t len) { + while (len > 0) { + ssize_t n = write(fd, buf, len); + + if (n < 0) + return n; + + buf += n; + len -= n; + } + + return 0; +} + + +// Buffers + +void uw_buffer_init(size_t max, uw_buffer *b, size_t s) { + b->max = max; + b->front = b->start = malloc(s); + b->back = b->front + s; +} + +void uw_buffer_free(uw_buffer *b) { + free(b->start); +} + +void uw_buffer_reset(uw_buffer *b) { + b->front = b->start; + if (b->front != b->back) { + *b->front = 0; + } +} + +int uw_buffer_check(uw_buffer *b, size_t extra) { + if (b->back - b->front < extra) { + size_t desired = b->front - b->start + extra, next; + char *new_heap; + + next = b->back - b->start; + if (next == 0) + next = 1; + for (; next < desired; next *= 2); + + if (next > b->max) { + if (desired <= b->max) + next = desired; + else + return 1; + } + + new_heap = realloc(b->start, next); + b->front = new_heap + (b->front - b->start); + b->back = new_heap + next; + b->start = new_heap; + } + + return 0; +} + +__attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *, ...); + +static void ctx_uw_buffer_check(uw_context ctx, const char *kind, uw_buffer *b, size_t extra) { + if (uw_buffer_check(b, extra)) + uw_error(ctx, FATAL, "Memory limit exceeded (%s)", kind); +} + +size_t uw_buffer_used(uw_buffer *b) { + return b->front - b->start; +} + +size_t uw_buffer_avail(uw_buffer *b) { + return b->back - b->start; +} + +int uw_buffer_append(uw_buffer *b, const char *s, size_t len) { + if (uw_buffer_check(b, len+1)) + return 1; + + memcpy(b->front, s, len); + b->front += len; + *b->front = 0; + + return 0; +} + +static void ctx_uw_buffer_append(uw_context ctx, const char *kind, uw_buffer *b, const char *s, size_t len) { + ctx_uw_buffer_check(ctx, kind, b, len+1); + + memcpy(b->front, s, len); + b->front += len; + *b->front = 0; +} + + +// Persistent state types + +typedef enum { UNUSED, USED } usage; + +typedef struct client { + unsigned id; + usage mode; + int pass; + struct client *next; + pthread_mutex_t lock, pull_lock; + uw_buffer msgs; + int sock; + int (*send)(int sockfd, const void *buf, ssize_t len); + int (*close)(int fd); + time_t last_contact; + unsigned n_channels; + unsigned refcount; + void *data; +} client; + + +// Persistent client state + +static client **clients, *clients_free, *clients_used; +static unsigned n_clients; + +static pthread_mutex_t clients_mutex = PTHREAD_MUTEX_INITIALIZER; +size_t uw_messages_max = SIZE_MAX; +size_t uw_clients_max = SIZE_MAX; + +void *uw_init_client_data(); +void uw_free_client_data(void *); +void uw_copy_client_data(void *dst, void *src); + +static uw_Basis_int my_rand() { + int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); + if (r) + return abs(ret); + else + return -1; +} + +static client *new_client(uw_context ctx) { + client *c; + int pass = my_rand(); + + if (pass < 0) uw_error(ctx, FATAL, "Random number generation failed during client initialization"); + + pthread_mutex_lock(&clients_mutex); + + if (clients_free) { + c = clients_free; + clients_free = clients_free->next; + } + else if (n_clients >= uw_clients_max) { + pthread_mutex_unlock(&clients_mutex); + return NULL; + } else { + ++n_clients; + clients = realloc(clients, sizeof(client) * n_clients); + c = malloc(sizeof(client)); + c->id = n_clients-1; + pthread_mutex_init(&c->lock, NULL); + pthread_mutex_init(&c->pull_lock, NULL); + uw_buffer_init(uw_messages_max, &c->msgs, 0); + clients[n_clients-1] = c; + } + + pthread_mutex_lock(&c->lock); + c->mode = USED; + c->pass = pass; + c->sock = -1; + c->last_contact = time(NULL); + uw_buffer_reset(&c->msgs); + c->n_channels = 0; + c->refcount = 0; + c->data = uw_init_client_data(); + pthread_mutex_unlock(&c->lock); + + c->next = clients_used; + clients_used = c; + + pthread_mutex_unlock(&clients_mutex); + + return c; +} + +static void use_client(client *c) { + pthread_mutex_lock(&c->lock); + ++c->refcount; + pthread_mutex_unlock(&c->lock); + pthread_mutex_lock(&c->pull_lock); +} + +static void release_client(client *c) { + pthread_mutex_unlock(&c->pull_lock); + pthread_mutex_lock(&c->lock); + --c->refcount; + pthread_mutex_unlock(&c->lock); +} + +static const char begin_msgs[] = "Content-type: text/plain\r\n\r\n"; +static pthread_t pruning_thread; +static int pruning_thread_initialized = 0; + +static client *find_client(unsigned id) { + client *c; + int i_am_pruner = pruning_thread_initialized && pthread_equal(pruning_thread, pthread_self()); + + if (!i_am_pruner) pthread_mutex_lock(&clients_mutex); + + if (id >= n_clients) { + if (!i_am_pruner) pthread_mutex_unlock(&clients_mutex); + return NULL; + } + + c = clients[id]; + + if (!i_am_pruner) pthread_mutex_unlock(&clients_mutex); + return c; +} + +static char *on_success = "HTTP/1.1 200 OK\r\n"; +static char *on_redirect = "HTTP/1.1 303 See Other\r\n"; + +void uw_set_on_success(char *s) { + on_success = s; +} + +static void chastise(int (*send)(int sockfd, const void *buf, ssize_t len), int sock) { + send(sock, on_success, strlen(on_success)); + send(sock, begin_msgs, sizeof(begin_msgs) - 1); + send(sock, "R", 1); + close(sock); +} + +void uw_client_connect(unsigned id, int pass, int sock, + int (*send)(int sockfd, const void *buf, ssize_t len), + int (*close)(int fd), + void *logger_data, uw_logger log_error) { + client *c = find_client(id); + + if (c == NULL) { + chastise(send, sock); + log_error(logger_data, "Out-of-bounds client request (%u)\n", id); + return; + } + + pthread_mutex_lock(&c->lock); + + if (c->mode != USED) { + pthread_mutex_unlock(&c->lock); + chastise(send, sock); + log_error(logger_data, "Client request for unused slot (%u)\n", id); + return; + } + + if (pass != c->pass) { + pthread_mutex_unlock(&c->lock); + chastise(send, sock); + log_error(logger_data, "Wrong client password (%u, %d)\n", id, pass); + return; + } + + if (c->sock != -1) { + c->close(c->sock); + c->sock = -1; + } + + c->last_contact = time(NULL); + + if (uw_buffer_used(&c->msgs) > 0) { + send(sock, on_success, strlen(on_success)); + send(sock, begin_msgs, sizeof(begin_msgs) - 1); + send(sock, c->msgs.start, uw_buffer_used(&c->msgs)); + uw_buffer_reset(&c->msgs); + close(sock); + } + else { + c->sock = sock; + c->send = send; + c->close = close; + } + + pthread_mutex_unlock(&c->lock); +} + +static void free_client(client *c) { + c->mode = UNUSED; + c->pass = -1; + + c->next = clients_free; + clients_free = c; +} + +static uw_Basis_channel new_channel(client *c) { + uw_Basis_channel ch = {c->id, c->n_channels++}; + return ch; +} + +static void client_send(client *c, uw_buffer *msg, const char *script, int script_len) { + pthread_mutex_lock(&c->lock); + + if (c->sock != -1) { + c->send(c->sock, on_success, strlen(on_success)); + c->send(c->sock, begin_msgs, sizeof(begin_msgs) - 1); + if (script_len > 0) { + c->send(c->sock, "E\n", 2); + c->send(c->sock, script, script_len); + c->send(c->sock, "\n", 1); + } + c->send(c->sock, msg->start, uw_buffer_used(msg)); + c->close(c->sock); + c->sock = -1; + } else if (uw_buffer_append(&c->msgs, msg->start, uw_buffer_used(msg))) + fprintf(stderr, "Client message buffer size exceeded"); + + pthread_mutex_unlock(&c->lock); +} + + +// Global entry points + +extern void uw_global_custom(); +extern void uw_init_crypto(); + +void uw_global_init() { + clients = malloc(0); + + uw_global_custom(); + uw_init_crypto(); + + // Fast non-cryptographic strength randomness for Sqlcache. + srandom(clock()); +} + +void uw_app_init(uw_app *app) { + app->client_init(); +} + +int uw_time = 0, uw_time_max = 0, uw_min_heap = 0; + + +// Single-request state + +typedef struct regions { + struct regions *next; +} regions; + +typedef struct { + void (*func)(void*); + void *arg; +} cleanup; + +typedef struct { + unsigned client; + uw_buffer msgs; +} delta; + +typedef enum { + UNSET, NORMAL, FIL, SUBFORM, SUBFORMS, ENTRY +} input_kind; + +typedef struct input { + input_kind kind; + union { + char *normal; + uw_Basis_file file; + struct { + struct input *fields, *parent; + } subform; + struct { + struct input *entries, *parent; + } subforms; + struct { + struct input *fields, *next, *parent; + } entry; + } data; +} input; + +typedef struct { + void *data; + uw_callback commit, rollback; + uw_callback_with_retry free; +} transactional; + +typedef struct { + char *name; + void *data; + void (*free)(void*); +} global; + +typedef struct uw_Sqlcache_Update { + uw_Sqlcache_Cache *cache; + char **keys; + uw_Sqlcache_Value *value; + struct uw_Sqlcache_Update *next; +} uw_Sqlcache_Update; + +typedef struct uw_Sqlcache_Unlock { + pthread_rwlock_t *lock; + struct uw_Sqlcache_Unlock *next; +} uw_Sqlcache_Unlock; + +struct uw_context { + uw_app *app; + int id; + + char *(*get_header)(void *, const char *); + void *get_header_data; + + char *(*get_env)(void *, const char *); + void *get_env_data; + + uw_buffer outHeaders, page, heap, script; + int allowed_to_return_indirectly, returning_indirectly; + input *inputs, *subinputs, *cur_container; + size_t sz_inputs, n_subinputs, used_subinputs; + + unsigned long long source_count; + + void *db; + int transaction_started; + + jmp_buf jmp_buf; + + regions *regions; + + cleanup *cleanup, *cleanup_front, *cleanup_back; + + const char *script_header; + + int needs_push, needs_sig, could_write_db, at_most_one_query; + + size_t n_deltas, used_deltas; + delta *deltas; + + client *client; + + transactional *transactionals; + size_t n_transactionals, used_transactionals; + + global *globals; + size_t n_globals; + + char *current_url; + + int deadline; + + void *client_data; + + uw_loggers *loggers; + + int isPost, hasPostBody; + uw_Basis_postBody postBody; + uw_Basis_string queryString; + + unsigned nextId; + + int amInitializing; + + char error_message[ERROR_BUF_LEN]; + + int usedSig, needsResig; + + char *output_buffer; + size_t output_buffer_size; + + // Sqlcache. + int numRecording, recordingCapacity; + int *recordingOffsets, *scriptRecordingOffsets; + uw_Sqlcache_Update *cacheUpdate; + uw_Sqlcache_Update *cacheUpdateTail; + uw_Sqlcache_Unlock *cacheUnlock; + + int remoteSock; +}; + +size_t uw_headers_max = SIZE_MAX; +size_t uw_page_max = SIZE_MAX; +size_t uw_heap_max = SIZE_MAX; +size_t uw_script_max = SIZE_MAX; + +uw_context uw_init(int id, uw_loggers *lg) { + uw_context ctx = malloc(sizeof(struct uw_context)); + + ctx->app = NULL; + ctx->id = id; + + ctx->get_header = NULL; + ctx->get_header_data = NULL; + + ctx->get_env = NULL; + ctx->get_env_data = NULL; + + uw_buffer_init(uw_headers_max, &ctx->outHeaders, 1); + ctx->outHeaders.start[0] = 0; + uw_buffer_init(uw_page_max, &ctx->page, 1); + ctx->page.start[0] = 0; + ctx->allowed_to_return_indirectly = ctx->returning_indirectly = 0; + uw_buffer_init(uw_heap_max, &ctx->heap, uw_min_heap); + uw_buffer_init(uw_script_max, &ctx->script, 1); + ctx->script.start[0] = 0; + + ctx->inputs = malloc(0); + ctx->cur_container = NULL; + ctx->subinputs = malloc(0); + ctx->sz_inputs = ctx->n_subinputs = ctx->used_subinputs = 0; + + ctx->db = NULL; + ctx->transaction_started = 0; + + ctx->regions = NULL; + + ctx->cleanup_front = ctx->cleanup_back = ctx->cleanup = malloc(0); + + ctx->script_header = ""; + ctx->needs_push = 0; + ctx->needs_sig = 0; + ctx->could_write_db = 1; + ctx->at_most_one_query = 0; + + ctx->source_count = 0; + + ctx->n_deltas = ctx->used_deltas = 0; + ctx->deltas = malloc(0); + + ctx->client = NULL; + + ctx->error_message[0] = 0; + + ctx->transactionals = malloc(0); + ctx->n_transactionals = ctx->used_transactionals = 0; + + ctx->globals = malloc(0); + ctx->n_globals = 0; + + ctx->current_url = ""; + + ctx->deadline = INT_MAX; + + ctx->client_data = uw_init_client_data(); + + ctx->loggers = lg; + + ctx->isPost = ctx->hasPostBody = 0; + + ctx->queryString = NULL; + + ctx->nextId = 0; + + ctx->amInitializing = 0; + + ctx->usedSig = 0; + ctx->needsResig = 0; + + ctx->output_buffer = malloc(1); + ctx->output_buffer_size = 1; + + ctx->numRecording = 0; + ctx->recordingCapacity = 0; + ctx->recordingOffsets = malloc(0); + ctx->scriptRecordingOffsets = malloc(0); + ctx->cacheUpdate = NULL; + ctx->cacheUpdateTail = NULL; + + ctx->remoteSock = -1; + + ctx->cacheUnlock = NULL; + + return ctx; +} + +size_t uw_inputs_max = SIZE_MAX; + +uw_app *uw_get_app(uw_context ctx) { + return ctx->app; +} + +int uw_set_app(uw_context ctx, uw_app *app) { + ctx->app = app; + + if (app && app->inputs_len > ctx->sz_inputs) { + if (app->inputs_len > uw_inputs_max) + return 1; + + ctx->sz_inputs = app->inputs_len; + ctx->inputs = realloc(ctx->inputs, ctx->sz_inputs * sizeof(input)); + memset(ctx->inputs, 0, ctx->sz_inputs * sizeof(input)); + } + + return 0; +} + +void uw_set_client_data(uw_context ctx, void *data) { + uw_copy_client_data(ctx->client_data, data); +} + +void uw_set_db(uw_context ctx, void *db) { + ctx->db = db; +} + +void *uw_get_db(uw_context ctx) { + return ctx->db; +} + + +uw_loggers* uw_get_loggers(struct uw_context *ctx) { + return ctx->loggers; +} + +void uw_free(uw_context ctx) { + size_t i; + + uw_buffer_free(&ctx->outHeaders); + uw_buffer_free(&ctx->script); + uw_buffer_free(&ctx->page); + uw_buffer_free(&ctx->heap); + free(ctx->inputs); + free(ctx->subinputs); + free(ctx->cleanup); + free(ctx->transactionals); + uw_free_client_data(ctx->client_data); + + for (i = 0; i < ctx->n_deltas; ++i) + uw_buffer_free(&ctx->deltas[i].msgs); + free(ctx->deltas); + + for (i = 0; i < ctx->n_globals; ++i) + if (ctx->globals[i].free) + ctx->globals[i].free(ctx->globals[i].data); + free(ctx->globals); + + free(ctx->output_buffer); + + free(ctx->recordingOffsets); + free(ctx->scriptRecordingOffsets); + + free(ctx); +} + +void uw_reset_keep_error_message(uw_context ctx) { + uw_buffer_reset(&ctx->outHeaders); + uw_buffer_reset(&ctx->script); + ctx->script.start[0] = 0; + uw_buffer_reset(&ctx->page); + ctx->allowed_to_return_indirectly = ctx->returning_indirectly = 0; + uw_buffer_reset(&ctx->heap); + ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup; + ctx->used_deltas = 0; + ctx->client = NULL; + ctx->cur_container = NULL; + ctx->used_transactionals = 0; + ctx->script_header = ""; + ctx->queryString = NULL; + ctx->nextId = 0; + ctx->amInitializing = 0; + ctx->usedSig = 0; + ctx->needsResig = 0; + ctx->remoteSock = -1; + ctx->numRecording = 0; +} + +void uw_reset_keep_request(uw_context ctx) { + uw_reset_keep_error_message(ctx); + ctx->error_message[0] = 0; +} + +void uw_reset(uw_context ctx) { + uw_reset_keep_request(ctx); + if (ctx->app) + memset(ctx->inputs, 0, ctx->app->inputs_len * sizeof(input)); + memset(ctx->subinputs, 0, ctx->n_subinputs * sizeof(input)); + ctx->used_subinputs = ctx->hasPostBody = ctx->isPost = 0; + ctx->transaction_started = 0; +} + +failure_kind uw_begin_init(uw_context ctx) { + int r = setjmp(ctx->jmp_buf); + + if (r == 0 && ctx->app) + ctx->app->db_init(ctx); + + return r; +} + +void uw_close(uw_context ctx) { + ctx->app->db_close(ctx); +} + +uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { + return ctx->get_header(ctx->get_header_data, h); +} + +void uw_set_headers(uw_context ctx, char *(*get_header)(void *, const char *), void *get_header_data) { + ctx->get_header = get_header; + ctx->get_header_data = get_header_data; +} + +void uw_set_env(uw_context ctx, char *(*get_env)(void *, const char *), void *get_env_data) { + ctx->get_env = get_env; + ctx->get_env_data = get_env_data; +} + +static void uw_set_error(uw_context ctx, const char *fmt, ...) { + va_list ap; + va_start(ap, fmt); + + vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap); +} + +int uw_has_error(uw_context ctx) { + return ctx->error_message[0] != 0; +} + +__attribute__((noreturn)) void uw_error(uw_context ctx, failure_kind fk, const char *fmt, ...) { + cleanup *cl; + + va_list ap; + va_start(ap, fmt); + + vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, fk); +} + +size_t uw_cleanup_max = SIZE_MAX; + +void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { + if (ctx->cleanup_front >= ctx->cleanup_back) { + int len = ctx->cleanup_back - ctx->cleanup, newLen; + if (len == 0) + newLen = 1; + else + newLen = len * 2; + + if (newLen > uw_cleanup_max) { + if (len+1 <= uw_cleanup_max) + newLen = uw_cleanup_max; + else + uw_error(ctx, FATAL, "Exceeded limit on number of cleanup handlers"); + } + + ctx->cleanup = realloc(ctx->cleanup, newLen * sizeof(cleanup)); + ctx->cleanup_front = ctx->cleanup + len; + ctx->cleanup_back = ctx->cleanup + newLen; + } + + ctx->cleanup_front->func = func; + ctx->cleanup_front->arg = arg; + ++ctx->cleanup_front; +} + +char *uw_Basis_htmlifyString(uw_context, const char *); + +void uw_login(uw_context ctx) { + char *id_s, *pass_s; + + if ((id_s = uw_Basis_requestHeader(ctx, "UrWeb-Client")) + && (pass_s = uw_Basis_requestHeader(ctx, "UrWeb-Pass"))) { + unsigned id = atoi(id_s); + int pass = atoi(pass_s); + client *c = find_client(id); + + if (c == NULL) + uw_error(ctx, FATAL, "Unknown client ID in HTTP headers (%s, %s)", uw_Basis_htmlifyString(ctx, id_s), uw_Basis_htmlifyString(ctx, pass_s)); + else { + use_client(c); + ctx->client = c; + + if (c->mode != USED) + uw_error(ctx, FATAL, "Stale client ID (%u) in subscription request", id); + if (c->pass != pass) + uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass); + } + } else if (ctx->needs_push) { + client *c = new_client(ctx); + + if (c == NULL) + uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients"); + + use_client(c); + uw_copy_client_data(c->data, ctx->client_data); + ctx->client = c; + } +} + +failure_kind uw_begin(uw_context ctx, char *path) { + int r = setjmp(ctx->jmp_buf); + + if (r == 0) + ctx->app->handle(ctx, path); + + return r; +} + +static void uw_try_reconnecting(uw_context ctx) { + // Hm, error starting transaction. + // Maybe the database server died but has since come back up. + // Let's try starting from scratch. + if (ctx->db) { + ctx->app->db_close(ctx); + ctx->db = NULL; + } + ctx->app->db_init(ctx); +} + +void uw_try_reconnecting_and_restarting(uw_context ctx) { + uw_try_reconnecting(ctx); + uw_error(ctx, BOUNDED_RETRY, "Restarting transaction after fixing database connection"); +} + +void uw_ensure_transaction(uw_context ctx) { + if (!ctx->transaction_started && !ctx->at_most_one_query) { + if (!ctx->db || ctx->app->db_begin(ctx, ctx->could_write_db)) { + uw_try_reconnecting(ctx); + + if (ctx->app->db_begin(ctx, ctx->could_write_db)) + uw_error(ctx, FATAL, "Error running SQL BEGIN"); + } + + ctx->transaction_started = 1; + } else if (ctx->at_most_one_query && !ctx->db) + uw_try_reconnecting(ctx); +} + +uw_Basis_client uw_Basis_self(uw_context ctx) { + if (ctx->client == NULL) + uw_error(ctx, FATAL, "Call to Basis.self() from page that has only server-side code"); + + return ctx->client->id; +} + +void uw_pop_cleanup(uw_context ctx) { + if (ctx->cleanup_front == ctx->cleanup) + uw_error(ctx, FATAL, "Attempt to pop from empty cleanup action stack"); + + --ctx->cleanup_front; + ctx->cleanup_front->func(ctx->cleanup_front->arg); +} + +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; +} + +static input *INP(uw_context ctx) { + if (ctx->cur_container == NULL) + return ctx->inputs; + else if (ctx->cur_container->kind == SUBFORM) + return ctx->cur_container->data.subform.fields; + else if (ctx->cur_container->kind == ENTRY) + return ctx->cur_container->data.entry.fields; + else + uw_error(ctx, FATAL, "INP: Wrong kind (%d, %p)", ctx->cur_container->kind, ctx->cur_container); +} + +static void adjust_pointer(input **ptr, input *old_start, input *new_start, size_t len) { + if (*ptr != NULL && *ptr >= old_start && *ptr < old_start + len) + *ptr += new_start - old_start; +} + +static void adjust_input(input *x, input *old_start, input *new_start, size_t len) { + switch (x->kind) { + case SUBFORM: + adjust_pointer(&x->data.subform.fields, old_start, new_start, len); + adjust_pointer(&x->data.subform.parent, old_start, new_start, len); + break; + case SUBFORMS: + adjust_pointer(&x->data.subforms.entries, old_start, new_start, len); + adjust_pointer(&x->data.subforms.parent, old_start, new_start, len); + break; + case ENTRY: + adjust_pointer(&x->data.entry.fields, old_start, new_start, len); + adjust_pointer(&x->data.entry.next, old_start, new_start, len); + adjust_pointer(&x->data.entry.parent, old_start, new_start, len); + break; + default: + break; + } +} + +size_t uw_subinputs_max = SIZE_MAX; + +static input *check_input_space(uw_context ctx, size_t len) { + size_t i; + input *r; + + if (ctx->used_subinputs + len >= ctx->n_subinputs) { + if (ctx->used_subinputs + len > uw_subinputs_max) + uw_error(ctx, FATAL, "Exceeded limit on number of subinputs"); + + input *new_subinputs = realloc(ctx->subinputs, sizeof(input) * (ctx->used_subinputs + len)); + + if (ctx->subinputs != new_subinputs) { + for (i = 0; i < ctx->used_subinputs; ++i) + adjust_input(&new_subinputs[i], ctx->subinputs, new_subinputs, ctx->used_subinputs); + for (i = 0; i < ctx->app->inputs_len; ++i) + adjust_input(&ctx->inputs[i], ctx->subinputs, new_subinputs, ctx->used_subinputs); + + adjust_pointer(&ctx->cur_container, ctx->subinputs, new_subinputs, ctx->used_subinputs); + + ctx->n_subinputs = ctx->used_subinputs + len; + ctx->subinputs = new_subinputs; + } + } + + r = &ctx->subinputs[ctx->used_subinputs]; + + for (i = 0; i < len; ++i) + ctx->subinputs[ctx->used_subinputs++].kind = UNSET; + + return r; +} + +int uw_set_input(uw_context ctx, const char *name, char *value) { + //printf("Input name %s\n", name); + + if (!strcasecmp(name, ".b")) { + int n = ctx->app->input_num(value); + input *inps; + + if (n < 0) { + uw_set_error(ctx, "Bad subform name %s", uw_Basis_htmlifyString(ctx, value)); + return -1; + } + + if (n >= ctx->app->inputs_len) { + uw_set_error(ctx, "For subform name %s, index %d is out of range", uw_Basis_htmlifyString(ctx, value), n); + return -1; + } + + inps = check_input_space(ctx, ctx->app->inputs_len); + + INP(ctx)[n].kind = SUBFORM; + INP(ctx)[n].data.subform.parent = ctx->cur_container; + INP(ctx)[n].data.subform.fields = inps; + ctx->cur_container = &INP(ctx)[n]; + } else if (!strcasecmp(name, ".e")) { + input *tmp; + + if (ctx->cur_container == NULL) { + uw_set_error(ctx, "Unmatched subform closer"); + return -1; + } + + tmp = ctx->cur_container; + switch (tmp->kind) { + case SUBFORM: + ctx->cur_container = tmp->data.subform.parent; + tmp->data.subform.parent = NULL; + break; + case SUBFORMS: + ctx->cur_container = tmp->data.subforms.parent; + tmp->data.subforms.parent = NULL; + break; + case ENTRY: + ctx->cur_container = tmp->data.entry.parent; + break; + default: + uw_set_error(ctx, "uw_set_input: Wrong kind"); + return -1; + } + } else if (!strcasecmp(name, ".s")) { + int n = ctx->app->input_num(value); + + if (n < 0) { + uw_set_error(ctx, "Bad subforms name %s", uw_Basis_htmlifyString(ctx, value)); + return -1; + } + + if (n >= ctx->app->inputs_len) { + uw_set_error(ctx, "For subforms name %s, index %d is out of range", uw_Basis_htmlifyString(ctx, value), n); + return -1; + } + + INP(ctx)[n].kind = SUBFORMS; + INP(ctx)[n].data.subforms.parent = ctx->cur_container; + INP(ctx)[n].data.subforms.entries = NULL; + ctx->cur_container = &INP(ctx)[n]; + } else if (!strcasecmp(name, ".i")) { + input *inps; + + if (!ctx->cur_container) { + uw_set_error(ctx, "New entry without container"); + return -1; + } + + if (ctx->cur_container->kind != SUBFORMS) { + uw_set_error(ctx, "Bad kind for entry parent"); + return -1; + } + + inps = check_input_space(ctx, ctx->app->inputs_len + 1); + + inps->kind = ENTRY; + inps->data.entry.parent = ctx->cur_container; + inps->data.entry.next = ctx->cur_container->data.subforms.entries; + ctx->cur_container->data.subforms.entries = inps; + + inps->data.entry.fields = inps+1; + ctx->cur_container = inps; + } else { + int n = ctx->app->input_num(name); + + if (n < 0) + return 0; + + if (n >= ctx->app->inputs_len) { + uw_set_error(ctx, "For input name %s, index %d is out of range", uw_Basis_htmlifyString(ctx, name), n); + return -1; + } + + INP(ctx)[n].kind = NORMAL; + INP(ctx)[n].data.normal = value; + } + + return 0; +} + +char *uw_get_input(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative input index %d", n); + if (n >= ctx->app->inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + return NULL; + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as normal"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as normal"); + case SUBFORMS: + uw_error(ctx, FATAL, "Tried to read a subforms form input as normal"); + case ENTRY: + uw_error(ctx, FATAL, "Tried to read an entry form input as normal"); + case NORMAL: + return INP(ctx)[n].data.normal; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +char *uw_get_optional_input(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative input index %d", n); + if (n >= ctx->app->inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + return ""; + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as normal"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as normal"); + case SUBFORMS: + uw_error(ctx, FATAL, "Tried to read a subforms form input as normal"); + case ENTRY: + uw_error(ctx, FATAL, "Tried to read an entry form input as normal"); + case NORMAL: + return INP(ctx)[n].data.normal; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +int uw_set_file_input(uw_context ctx, const char *name, uw_Basis_file f) { + int n = ctx->app->input_num(name); + + if (n < 0) { + uw_set_error(ctx, "Bad file input name"); + return -1; + } + + if (n >= ctx->app->inputs_len) { + uw_set_error(ctx, "For file input name, index %d is out of range", n); + return -1; + } + + ctx->inputs[n].kind = FIL; + ctx->inputs[n].data.file = f; + + return 0; +} + +void *uw_malloc(uw_context ctx, size_t len); + +uw_Basis_file uw_get_file_input(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative file input index %d", n); + if (n >= ctx->app->inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds file input index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + { + char *data = uw_malloc(ctx, 0); + uw_Basis_file f = {NULL, "", {0, data}}; + return f; + } + case FIL: + return INP(ctx)[n].data.file; + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input as files"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as files"); + case SUBFORMS: + uw_error(ctx, FATAL, "Tried to read a subforms form input as files"); + case ENTRY: + uw_error(ctx, FATAL, "Tried to read an entry form input as files"); + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +void uw_enter_subform(uw_context ctx, int n) { + if (n < 0) + uw_error(ctx, FATAL, "Negative subform index %d", n); + if (n >= ctx->app->inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds subform index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + uw_error(ctx, FATAL, "Missing subform"); + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as subform"); + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input as subform"); + case SUBFORMS: + uw_error(ctx, FATAL, "Tried to read a subforms form input as subform"); + case ENTRY: + uw_error(ctx, FATAL, "Tried to read an entry form input as subform"); + case SUBFORM: + INP(ctx)[n].data.subform.parent = ctx->cur_container; + ctx->cur_container = &INP(ctx)[n]; + return; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +void uw_leave_subform(uw_context ctx) { + input *tmp; + + if (ctx->cur_container == NULL) + uw_error(ctx, FATAL, "Unmatched uw_leave_subform"); + + tmp = ctx->cur_container; + ctx->cur_container = tmp->data.subform.parent; + tmp->data.subform.parent = NULL; +} + +int uw_enter_subforms(uw_context ctx, int n) { + input *inps; + + if (n < 0) + uw_error(ctx, FATAL, "Negative subforms index %d", n); + if (n >= ctx->app->inputs_len) + uw_error(ctx, FATAL, "Out-of-bounds subforms index %d", n); + + switch (INP(ctx)[n].kind) { + case UNSET: + uw_error(ctx, FATAL, "Missing subforms"); + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as subforms"); + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input %p as subforms", &INP(ctx)[n]); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as subforms"); + case ENTRY: + uw_error(ctx, FATAL, "Tried to read an entry form input as subforms"); + case SUBFORMS: + inps = INP(ctx)[n].data.subforms.entries; + if (inps) { + INP(ctx)[n].data.subforms.parent = ctx->cur_container; + ctx->cur_container = INP(ctx)[n].data.subforms.entries; + return 1; + } else + return 0; + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +int uw_next_entry(uw_context ctx) { + if (ctx->cur_container == NULL) + uw_error(ctx, FATAL, "uw_next_entry(NULL)"); + + switch (ctx->cur_container->kind) { + case UNSET: + uw_error(ctx, FATAL, "Missing entry"); + case FIL: + uw_error(ctx, FATAL, "Tried to read a file form input as entry"); + case NORMAL: + uw_error(ctx, FATAL, "Tried to read a normal form input as entry"); + case SUBFORM: + uw_error(ctx, FATAL, "Tried to read a subform form input as entry"); + case SUBFORMS: + uw_error(ctx, FATAL, "Tried to read a subforms form input as entry"); + case ENTRY: + if (ctx->cur_container->data.entry.next) { + ctx->cur_container = ctx->cur_container->data.entry.next; + return 1; + } else { + ctx->cur_container = ctx->cur_container->data.entry.parent->data.subforms.parent; + return 0; + } + default: + uw_error(ctx, FATAL, "Impossible input kind"); + } +} + +void uw_set_script_header(uw_context ctx, const char *s) { + ctx->script_header = s; +} + +const char *uw_get_url_prefix(uw_context ctx) { + return ctx->app->url_prefix; +} + +void uw_set_needs_push(uw_context ctx, int n) { + ctx->needs_push = n; +} + +void uw_set_needs_sig(uw_context ctx, int n) { + ctx->needs_sig = n; +} + +void uw_set_could_write_db(uw_context ctx, int n) { + ctx->could_write_db = n; +} + +void uw_set_at_most_one_query(uw_context ctx, int n) { + ctx->at_most_one_query = n; +} + + +static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) { + if (b->back - b->front < extra) { + size_t desired = b->front - b->start + extra, next; + char *new_heap; + + next = b->back - b->start; + if (next == 0) + next = 1; + for (; next < desired; next *= 2); + + if (next > b->max) { + if (desired <= b->max) + next = desired; + else + uw_error(ctx, FATAL, "Memory limit exceeded (%s)", kind); + } + + new_heap = realloc(b->start, next); + b->front = new_heap + (b->front - b->start); + b->back = new_heap + next; + + if (new_heap != b->start) { + b->start = new_heap; + uw_error(ctx, UNLIMITED_RETRY, "Couldn't allocate new %s contiguously; increasing size to %llu", desc, (unsigned long long)next); + } + + b->start = new_heap; + } +} + +void uw_check_heap(uw_context ctx, size_t extra) { + uw_buffer_check_ctx(ctx, "heap", &ctx->heap, extra, "heap chunk"); +} + +char *uw_heap_front(uw_context ctx) { + return ctx->heap.front; +} + +void uw_set_heap_front(uw_context ctx, char *fr) { + ctx->heap.front = fr; +} + +void uw_begin_initializing(uw_context ctx) { + ctx->amInitializing = 1; +} + +void uw_end_initializing(uw_context ctx) { + ctx->amInitializing = 0; +} + +static void align_heap(uw_context ctx) { + size_t posn = ctx->heap.front - ctx->heap.start; + + if (posn % sizeof(void *) != 0) { + size_t bump = sizeof(void *) - posn % sizeof(void *); + uw_check_heap(ctx, bump); + ctx->heap.front += bump; + } +} + +void *uw_malloc(uw_context ctx, size_t len) { + // On some architectures, it's important that all word-sized memory accesses + // be to word-aligned addresses, so we'll do a little bit of extra work here + // in anticipation of a possible word-aligned access to the address we'll + // return. + + void *result; + + if (ctx->amInitializing) { + int error = posix_memalign(&result, sizeof(void *), len); + + if (!error) + return result; + else + uw_error(ctx, FATAL, "uw_malloc: posix_memalign() returns %d", error); + } else { + align_heap(ctx); + + uw_check_heap(ctx, len); + + result = ctx->heap.front; + ctx->heap.front += len; + return result; + } +} + +void uw_begin_region(uw_context ctx) { + align_heap(ctx); + + regions *r = (regions *) ctx->heap.front; + + uw_check_heap(ctx, sizeof(regions)); + + ctx->heap.front += sizeof(regions); + + r->next = ctx->regions; + ctx->regions = r; +} + +void uw_end_region(uw_context ctx) { + regions *r = ctx->regions; + + if (r == NULL) + uw_error(ctx, FATAL, "Region stack underflow"); + + ctx->heap.front = (char *) r; + ctx->regions = r->next; +} + +void uw_memstats(uw_context ctx) { + printf("Headers: %lu/%lu\n", (unsigned long)uw_buffer_used(&ctx->outHeaders), (unsigned long)uw_buffer_avail(&ctx->outHeaders)); + printf("Script: %lu/%lu\n", (unsigned long)uw_buffer_used(&ctx->script), (unsigned long)uw_buffer_avail(&ctx->script)); + printf("Page: %lu/%lu\n", (unsigned long)uw_buffer_used(&ctx->page), (unsigned long)uw_buffer_avail(&ctx->page)); + printf("Heap: %lu/%lu\n", (unsigned long)uw_buffer_used(&ctx->heap), (unsigned long)uw_buffer_avail(&ctx->heap)); +} + +int uw_pagelen(uw_context ctx) { + return ctx->page.front - ctx->page.start; +} + +int uw_send(uw_context ctx, int sock) { + size_t target_length = (ctx->outHeaders.front - ctx->outHeaders.start) + 2 + (ctx->page.front - ctx->page.start); + + if (ctx->output_buffer_size < target_length) { + do { + ctx->output_buffer_size *= 2; + } while (ctx->output_buffer_size < target_length); + ctx->output_buffer = realloc(ctx->output_buffer, ctx->output_buffer_size); + } + + memcpy(ctx->output_buffer, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start); + memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start), "\r\n", 2); + memcpy(ctx->output_buffer + (ctx->outHeaders.front - ctx->outHeaders.start) + 2, ctx->page.start, ctx->page.front - ctx->page.start); + + return uw_really_send(sock, ctx->output_buffer, target_length); +} + +int uw_print(uw_context ctx, int fd) { + int n = uw_really_write(fd, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start); + + if (n < 0) + return n; + + n = uw_really_write(fd, "\r\n", 2); + + if (n < 0) + return n; + + return uw_really_write(fd, ctx->page.start, ctx->page.front - ctx->page.start); +} + +int uw_output(uw_context ctx, int (*output)(void *data, char *buf, size_t len), void *data) { + int n = output(data, ctx->outHeaders.start, ctx->outHeaders.front - ctx->outHeaders.start); + + if (n < 0) + return n; + + n = output(data, "\r\n", 2); + + if (n < 0) + return n; + + return output(data, ctx->page.start, ctx->page.front - ctx->page.start); +} + +static void uw_check_headers(uw_context ctx, size_t extra) { + ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, extra); +} + +void uw_write_header(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + + uw_check_headers(ctx, len + 1); + strcpy(ctx->outHeaders.front, s); + ctx->outHeaders.front += len; +} + +int uw_has_contentLength(uw_context ctx) { + return strstr(ctx->outHeaders.start, "Content-length: ") != NULL; +} + +void uw_clear_headers(uw_context ctx) { + uw_buffer_reset(&ctx->outHeaders); +} + +void uw_Basis_clear_page(uw_context ctx) { + uw_buffer_reset(&ctx->page); +} + +static void uw_check_script(uw_context ctx, size_t extra) { + ctx_uw_buffer_check(ctx, "script", &ctx->script, extra); +} + +void uw_write_script(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + + uw_check_script(ctx, len + 1); + strcpy(ctx->script.front, s); + ctx->script.front += len; +} + +const char *uw_get_real_script(uw_context ctx) { + if (strstr(ctx->outHeaders.start, "Set-Cookie: ")) { + uw_write_script(ctx, "sig=\""); + uw_write_script(ctx, ctx->app->cookie_sig(ctx)); + uw_write_script(ctx, "\";"); + } + + return ctx->script.start; +} + +uw_Basis_string uw_Basis_maybe_onload(uw_context ctx, uw_Basis_string s) { + if (s[0] == 0) + return ""; + else { + char *r = uw_malloc(ctx, 11 + strlen(s)); + sprintf(r, " onload='%s'", s); + return r; + } +} + +uw_Basis_string uw_Basis_maybe_onunload(uw_context ctx, uw_Basis_string s) { + if (ctx->script_header[0] == 0) + return ""; + else { + char *r = uw_malloc(ctx, 37 + strlen(s)); + sprintf(r, " onunload='unloading=true;%s;unload()'", s); + return r; + } +} + +const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { + if (ctx->client == NULL) { + if (ctx->needs_sig) { + char *sig = ctx->app->cookie_sig(ctx); + char *r = uw_malloc(ctx, strlen(sig) + 8); + sprintf(r, "sig=\"%s\";", sig); + return r; + } + else + return ""; + } else { + char *sig = ctx->needs_sig ? ctx->app->cookie_sig(ctx) : ""; + char *r = uw_malloc(ctx, 59 + 3 * INTS_MAX + strlen(ctx->app->url_prefix) + + (ctx->needs_sig ? strlen(sig) + 7 : 0)); + sprintf(r, "isPost=%s;client_id=%u;client_pass=%d;url_prefix=\"%s\";timeout=%d;%s%s%slistener();", + (ctx->isPost ? "true" : "false"), + ctx->client->id, + ctx->client->pass, + ctx->app->url_prefix, + ctx->app->timeout, + ctx->needs_sig ? "sig=\"" : "", + sig, + ctx->needs_sig ? "\";" : ""); + return r; + } +} + +uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 4 + 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; + } + } + } + + strcpy(s2, "\""); + ctx->heap.front = s2 + 2; + return r; +} + +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); + + 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; + } + } + + strcpy(s2, "\""); + ctx->heap.front = s2 + 2; + return r; +} + +uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_script(ctx, strlen(s) * 4 + 3); + + r = s2 = ctx->script.front; + *s2++ = '"'; + + for (; *s; s++) { + unsigned char c = *s; + + switch (c) { + case '\'': + strcpy(s2, "\\"); + s2 += 2; + 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; + } + } + } + + strcpy(s2, "\""); + ctx->script.front = s2 + 1; + return r; +} + +char *uw_Basis_jsifyChannel(uw_context ctx, uw_Basis_channel chn) { + if (ctx->client == NULL || chn.cli != ctx->client->id) + return "null"; + else { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 1); + r = ctx->heap.front; + sprintf(r, "%u%n", chn.chn, &len); + ctx->heap.front += len+1; + return r; + } +} + +uw_Basis_source uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) { + int len; + size_t s_len = strlen(s); + + if(ctx->id < 0) + uw_error(ctx, FATAL, "Attempt to create client source using inappropriate context"); + + uw_check_script(ctx, 15 + 2 * INTS_MAX + s_len); + sprintf(ctx->script.front, "s%d_%llu=sc(exec(%n", ctx->id, ctx->source_count, &len); + ctx->script.front += len; + strcpy(ctx->script.front, s); + ctx->script.front += s_len; + strcpy(ctx->script.front, "));"); + ctx->script.front += 3; + + uw_Basis_source r = {ctx->id, ctx->source_count++}; + return r; +} + +uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_source src, uw_Basis_string s) { + int len; + size_t s_len = strlen(s); + + uw_check_script(ctx, 15 + 2 * INTS_MAX + s_len); + sprintf(ctx->script.front, "sv(s%d_%llu,exec(%n", src.context, src.source, &len); + ctx->script.front += len; + strcpy(ctx->script.front, s); + ctx->script.front += s_len; + strcpy(ctx->script.front, "));"); + ctx->script.front += 3; + + return uw_unit_v; +} + +static void uw_check(uw_context ctx, size_t extra) { + ctx_uw_buffer_check(ctx, "page", &ctx->page, extra); +} + +static void uw_writec_unsafe(uw_context ctx, char c) { + *(ctx->page.front)++ = c; + *ctx->page.front = 0; +} + +void uw_writec(uw_context ctx, char c) { + uw_check(ctx, 2); + uw_writec_unsafe(ctx, c); +} + +void uw_Basis_writec(uw_context ctx, char c) { + uw_writec(ctx, c); +} + +static void uw_write_unsafe(uw_context ctx, const char* s) { + int len = strlen(s); + memcpy(ctx->page.front, s, len); + ctx->page.front += len; +} + +void uw_write(uw_context ctx, const char* s) { + uw_check(ctx, strlen(s) + 1); + uw_write_unsafe(ctx, s); + *ctx->page.front = 0; +} + +void uw_recordingStart(uw_context ctx) { + if (ctx->numRecording == ctx->recordingCapacity) { + ++ctx->recordingCapacity; + ctx->recordingOffsets = realloc(ctx->recordingOffsets, sizeof(int) * ctx->recordingCapacity); + ctx->scriptRecordingOffsets = realloc(ctx->scriptRecordingOffsets, sizeof(int) * ctx->recordingCapacity); + } + ctx->recordingOffsets[ctx->numRecording] = ctx->page.front - ctx->page.start; + ctx->scriptRecordingOffsets[ctx->numRecording] = ctx->script.front - ctx->script.start; + ++ctx->numRecording; +} + +char *uw_recordingRead(uw_context ctx) { + char *recording = ctx->page.start + ctx->recordingOffsets[ctx->numRecording-1]; + return strdup(recording); +} + +char *uw_recordingReadScript(uw_context ctx) { + char *recording = ctx->script.start + ctx->scriptRecordingOffsets[--ctx->numRecording]; + return strdup(recording); +} + +char *uw_Basis_attrifyInt(uw_context ctx, uw_Basis_int n) { + char *result; + int len; + uw_check_heap(ctx, INTS_MAX); + result = ctx->heap.front; + sprintf(result, "%lld%n", n, &len); + ctx->heap.front += len+1; + return result; +} + +char *uw_Basis_attrifyFloat(uw_context ctx, uw_Basis_float n) { + char *result; + int len; + uw_check_heap(ctx, FLOATS_MAX); + result = ctx->heap.front; + sprintf(result, "%.16g%n", n, &len); + ctx->heap.front += len+1; + return result; +} + +char *uw_Basis_attrifyString(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + char *result, *p; + uw_check_heap(ctx, len * 6 + 1); + + result = p = ctx->heap.front; + + for (; *s; s++) { + unsigned char c = *s; + + if (c == '"') { + strcpy(p, """); + p += 6; + } else if (c == '&') { + strcpy(p, "&"); + p += 5; + } + else + *p++ = c; + } + + *p++ = 0; + ctx->heap.front = p; + return result; +} + +char *uw_Basis_attrifyChar(uw_context ctx, uw_Basis_char c) { + char *result, *p; + uw_check_heap(ctx, 7); + + result = p = ctx->heap.front; + + if (c == '"') { + strcpy(p, """); + p += 6; + } else if (c == '&') { + strcpy(p, "&"); + p += 5; + } + else + *p++ = c; + + *p++ = 0; + ctx->heap.front = p; + return result; +} + +char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) { + return s; +} + +static void uw_Basis_attrifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { + int len; + + sprintf(ctx->page.front, "%lld%n", n, &len); + ctx->page.front += len; +} + +uw_unit uw_Basis_attrifyInt_w(uw_context ctx, uw_Basis_int n) { + uw_check(ctx, INTS_MAX); + uw_Basis_attrifyInt_w_unsafe(ctx, n); + + return uw_unit_v; +} + +uw_unit uw_Basis_attrifyFloat_w(uw_context ctx, uw_Basis_float n) { + int len; + + uw_check(ctx, FLOATS_MAX); + sprintf(ctx->page.front, "%g%n", n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +uw_unit uw_Basis_attrifyString_w(uw_context ctx, uw_Basis_string s) { + uw_check(ctx, strlen(s) * 6); + + for (; *s; s++) { + unsigned char c = *s; + + if (c == '"') + uw_write_unsafe(ctx, """); + else if (c == '&') + uw_write_unsafe(ctx, "&"); + else + uw_writec_unsafe(ctx, c); + } + + return uw_unit_v; +} + +uw_unit uw_Basis_attrifyChar_w(uw_context ctx, uw_Basis_char c) { + uw_check(ctx, 6); + + if (c == '"') + uw_write_unsafe(ctx, """); + else if (c == '&') + uw_write_unsafe(ctx, "&"); + else + uw_writec_unsafe(ctx, c); + + return uw_unit_v; +} + + +char *uw_Basis_urlifyInt(uw_context ctx, uw_Basis_int n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_Basis_urlifyChannel(uw_context ctx, uw_Basis_channel chn) { + if (ctx->client == NULL || chn.cli != ctx->client->id) + return ""; + else { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 1); + r = ctx->heap.front; + sprintf(r, "%u%n", chn.chn, &len); + ctx->heap.front += len+1; + return r; + } +} + +char *uw_Basis_urlifyFloat(uw_context ctx, uw_Basis_float n) { + int len; + char *r; + + uw_check_heap(ctx, FLOATS_MAX); + r = ctx->heap.front; + sprintf(r, "%g%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +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] == '_')); + + r = p = ctx->heap.front; + if (s[0] == '_') + *p++ = '_'; + + for (; *s; s++) { + unsigned char c = *s; + + if (c == ' ') + *p++ = '+'; + else if (isalnum(c)) + *p++ = c; + else { + sprintf(p, ".%02X", c); + p += 3; + } + } + + *p++ = 0; + ctx->heap.front = p; + return r; +} + +char *uw_Basis_urlifyBool(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) + return "0"; + else + return "1"; +} + +char *uw_Basis_urlifySource(uw_context ctx, uw_Basis_source src) { + char *r; + int len; + uw_check_heap(ctx, 2 * INTS_MAX + 2); + r = ctx->heap.front; + sprintf(r, "%d/%llu%n", src.context, src.source, &len); + ctx->heap.front += len+1; + return r; +} + +static void uw_Basis_urlifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { + int len; + + sprintf(ctx->page.front, "%lld%n", n, &len); + ctx->page.front += len; +} + +uw_unit uw_Basis_urlifyInt_w(uw_context ctx, uw_Basis_int n) { + uw_check(ctx, INTS_MAX); + uw_Basis_urlifyInt_w_unsafe(ctx, n); + + return uw_unit_v; +} + +uw_unit uw_Basis_urlifyChannel_w(uw_context ctx, uw_Basis_channel chn) { + if (ctx->client != NULL && chn.cli == ctx->client->id) { + int len; + + uw_check(ctx, INTS_MAX + 1); + sprintf(ctx->page.front, "%u%n", chn.chn, &len); + ctx->page.front += len; + } + + return uw_unit_v; +} + +uw_unit uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) { + int len; + + uw_check(ctx, FLOATS_MAX); + sprintf(ctx->page.front, "%g%n", n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +uw_Basis_string uw_Basis_urlifyTime(uw_context ctx, uw_Basis_time t) { + return uw_Basis_urlifyInt(ctx, (uw_Basis_int)t.seconds * 1000000 + t.microseconds); +} + +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_urlifyString_w(uw_context ctx, uw_Basis_string s) { + if (s[0] == '\0') { + uw_check(ctx, 1); + uw_writec_unsafe(ctx, '_'); + return uw_unit_v; + } + + uw_check(ctx, strlen(s) * 3 + !!(s[0] == '_')); + + if (s[0] == '_') + uw_writec_unsafe(ctx, '_'); + + for (; *s; s++) { + unsigned char c = *s; + + if (c == ' ') + uw_writec_unsafe(ctx, '+'); + else if (isalnum(c)) + uw_writec_unsafe(ctx, c); + else { + sprintf(ctx->page.front, ".%02X", c); + ctx->page.front += 3; + } + } + + return uw_unit_v; +} + +uw_unit uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) + uw_writec(ctx, '0'); + else + uw_writec(ctx, '1'); + + return uw_unit_v; +} + +uw_unit uw_Basis_urlifySource_w(uw_context ctx, uw_Basis_source src) { + int len; + + uw_check(ctx, 2 * INTS_MAX + 2); + sprintf(ctx->page.front, "%d/%llu%n", src.context, src.source, &len); + ctx->page.front += len; + + return uw_unit_v; +} + + +static char *uw_unurlify_advance(char *s) { + char *new_s = strchr(s, '/'); + + if (new_s) + *new_s++ = 0; + else + new_s = strchr(s, 0); + + return new_s; +} + +uw_Basis_int uw_Basis_unurlifyInt(uw_context ctx, char **s) { + char *new_s = uw_unurlify_advance(*s); + uw_Basis_int r; + + r = atoll(*s); + *s = new_s; + return r; +} + +uw_Basis_float uw_Basis_unurlifyFloat(uw_context ctx, char **s) { + char *new_s = uw_unurlify_advance(*s); + uw_Basis_float r; + + r = atof(*s); + *s = new_s; + return r; +} + +uw_Basis_time uw_Basis_unurlifyTime(uw_context ctx, char **s) { + uw_Basis_int n = uw_Basis_unurlifyInt(ctx, s); + uw_Basis_time r = {n / 1000000, n % 1000000}; + return r; +} + +static uw_Basis_string uw_unurlifyString_to(int fromClient, uw_context ctx, char *r, char *s) { + char *s1, *s2 = s; + int n; + + if (!fromClient) { + if (*s2 == '_') + ++s2; + else if ((s2[0] == '%' || s2[0] == '.') && s2[1] == '5' && (s2[2] == 'f' || s2[2] == 'F')) + s2 += 3; + } + + for (s1 = r; *s2; ++s1, ++s2) { + unsigned char c = *s2; + + switch (c) { + case '+': + *s1 = ' '; + break; + case '%': + if (s2[1] == 0) + uw_error(ctx, FATAL, "Missing first character of escaped URL byte"); + if (s2[2] == 0) + uw_error(ctx, FATAL, "Missing second character of escaped URL byte"); + if (sscanf(s2+1, "%02X", &n) != 1) + uw_error(ctx, FATAL, "Invalid escaped URL byte starting at: %s", uw_Basis_htmlifyString(ctx, s2)); + *s1 = n; + s2 += 2; + break; + case '.': + if (!fromClient) { + if (s2[1] == 0) + uw_error(ctx, FATAL, "Missing first character of escaped URL byte"); + if (s2[2] == 0) + uw_error(ctx, FATAL, "Missing second character of escaped URL byte"); + if (sscanf(s2+1, "%02X", &n) != 1) + uw_error(ctx, FATAL, "Invalid escaped URL byte starting at: %s", uw_Basis_htmlifyString(ctx, s2)); + *s1 = n; + s2 += 2; + break; + } + default: + *s1 = c; + } + } + *s1++ = 0; + return s1; +} + +uw_Basis_bool uw_Basis_unurlifyBool(uw_context ctx, char **s) { + char *new_s = uw_unurlify_advance(*s); + uw_Basis_bool r; + + if (*s[0] == 0 || !strcmp(*s, "0") || !strcmp(*s, "off")) + r = uw_Basis_False; + else + r = uw_Basis_True; + + *s = new_s; + return r; +} + +uw_Basis_string uw_Basis_unurlifyString(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; + return r; +} + +uw_Basis_unit uw_Basis_unurlifyUnit(uw_context ctx, char **s) { + *s = uw_unurlify_advance(*s); + return uw_unit_v; +} + +uw_Basis_string uw_Basis_unurlifyString_fromClient(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(1, ctx, ctx->heap.front, *s); + *s = new_s; + return r; +} + + +char *uw_Basis_htmlifyInt(uw_context ctx, uw_Basis_int n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { + int len; + + uw_check(ctx, INTS_MAX); + sprintf(ctx->page.front, "%lld%n", n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +char *uw_Basis_htmlifySpecialChar(uw_context ctx, unsigned char ch) { + unsigned int n = ch; + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX+3); + r = ctx->heap.front; + sprintf(r, "&#%u;%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, unsigned char ch) { + unsigned int n = ch; + int len; + + uw_check(ctx, INTS_MAX+3); + sprintf(ctx->page.front, "&#%u;%n", n, &len); + ctx->page.front += len; + return uw_unit_v; +} + +char *uw_Basis_htmlifyFloat(uw_context ctx, uw_Basis_float n) { + int len; + char *r; + + uw_check_heap(ctx, FLOATS_MAX); + r = ctx->heap.front; + sprintf(r, "%g%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_htmlifyFloat_w(uw_context ctx, uw_Basis_float n) { + int len; + + uw_check(ctx, FLOATS_MAX); + sprintf(ctx->page.front, "%g%n", n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +char *uw_Basis_jsifyTime(uw_context ctx, uw_Basis_time t) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", (uw_Basis_int)t.seconds * 1000000 + t.microseconds, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_int n) { + int len; + + uw_check(ctx, INTS_MAX); + sprintf(ctx->page.front, "%lld%n", (uw_Basis_int)n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +char *uw_Basis_htmlifyString(uw_context ctx, const char *s) { + char *r, *s2; + + 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; + } + } + + *s2++ = 0; + ctx->heap.front = s2; + return r; +} + +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); + } + } + + return uw_unit_v; +} + +uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) + return "False"; + else + return "True"; +} + +uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) { + uw_check(ctx, 6); + strcpy(ctx->page.front, "False"); + ctx->page.front += 5; + } else { + uw_check(ctx, 5); + strcpy(ctx->page.front, "True"); + ctx->page.front += 4; + } + + return uw_unit_v; +} + +#define TIME_FMT "%x %X" +#define TIME_FMT_PG "%Y-%m-%d %T" +#define TIME_FMT_JS "%Y/%m/%d %T" + +uw_Basis_string uw_Basis_timeToString(uw_context, uw_Basis_time); + +uw_Basis_string uw_Basis_htmlifyTime(uw_context ctx, uw_Basis_time t) { + return uw_Basis_htmlifyString(ctx, uw_Basis_timeToString(ctx, t)); +} + +uw_unit uw_Basis_htmlifyTime_w(uw_context ctx, uw_Basis_time t) { + return uw_Basis_htmlifyString_w(ctx, uw_Basis_timeToString(ctx, t)); +} + +char *uw_Basis_htmlifySource(uw_context ctx, uw_Basis_source src) { + int len; + char *r; + + uw_check_heap(ctx, 2 * INTS_MAX + 2); + r = ctx->heap.front; + sprintf(r, "s%d_%llu%n", src.context, src.source, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_htmlifySource_w(uw_context ctx, uw_Basis_source src) { + int len; + + uw_check(ctx, 2 * INTS_MAX + 1); + sprintf(ctx->page.front, "s%d_%llu%n", src.context, src.source, &len); + ctx->page.front += len; + + return uw_unit_v; +} + +uw_Basis_char uw_Basis_strsub(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + while (n >= 0) { + if (*s == 0) + uw_error(ctx, FATAL, "Out-of-bounds strsub"); + + if (n == 0) + return *s; + + --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) { + while (n >= 0) { + if (*s == 0 || n == 0) + return s; + + --n; + ++s; + } + + uw_error(ctx, FATAL, "Negative strsuffix bound"); +} + +uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) { + return strlen(s); +} + +uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + while (n > 0) { + if (*s == 0) + return uw_Basis_False; + + --n; + ++s; + } + + return uw_Basis_True; +} + +uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { + return strchr(s, ch); +} + +uw_Basis_int uw_Basis_strcspn(uw_context ctx, uw_Basis_string s, uw_Basis_string chs) { + return strcspn(s, chs); +} + +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) + return NULL; + else { + uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); + *nr = r - s; + return nr; + } +} + +uw_Basis_int *uw_Basis_strsindex(uw_context ctx, const char *haystack, const char *needle) { + uw_Basis_string r = strstr(haystack, needle); + if (r == NULL) + return NULL; + else { + uw_Basis_int *nr = uw_malloc(ctx, sizeof(uw_Basis_int)); + *nr = r - haystack; + 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; + char *s; + + uw_check_heap(ctx, len); + + s = ctx->heap.front; + + strcpy(s, s1); + strcat(s, s2); + ctx->heap.front += len; + + return s; +} + +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); + + if (start < 0) + uw_error(ctx, FATAL, "substring: Negative start index"); + if (len < 0) + uw_error(ctx, FATAL, "substring: Negative length"); + 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; + return r; + } + +} + +uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) { + char *r; + + uw_check_heap(ctx, 2); + r = ctx->heap.front; + r[0] = ch; + r[1] = 0; + + ctx->heap.front += 2; + + return r; +} + +uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { + int len = uw_Basis_strlen(ctx, s1) + 1; + char *s; + + uw_check_heap(ctx, len); + + s = ctx->heap.front; + + strcpy(s, s1); + ctx->heap.front += len; + + return s; +} + +uw_Basis_string uw_dup_and_clear_error_message(uw_context ctx) { + if (ctx->error_message[0]) { + char *s = uw_strdup(ctx, ctx->error_message); + ctx->error_message[0] = 0; + return s; + } else + return NULL; +} + +uw_Basis_string uw_maybe_strdup(uw_context ctx, uw_Basis_string s1) { + if (s1) + return uw_strdup(ctx, s1); + else + return NULL; +} + +char *uw_memdup(uw_context ctx, const char *p, size_t len) { + char *r = uw_malloc(ctx, len); + memcpy(r, p, len); + return r; +} + +char *uw_sqlfmtInt = "%lld::int8%n"; + +char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 6); + r = ctx->heap.front; + sprintf(r, uw_sqlfmtInt, n, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyInt(ctx, *n); +} + +char *uw_sqlfmtFloat = "%.16g::float8%n"; + +char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { + int len; + char *r; + + uw_check_heap(ctx, FLOATS_MAX + 8); + r = ctx->heap.front; + sprintf(r, uw_sqlfmtFloat, n, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) { + if (n == NULL) + return "NULL"; + else + return uw_Basis_sqlifyFloat(ctx, *n); +} + +int uw_Estrings = 1, uw_sql_type_annotations = 1; +char *uw_sqlsuffixString = "::text"; +char *uw_sqlsuffixChar = "::char"; + +uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { + char *r, *s2; + + uw_check_heap(ctx, strlen(s) * 2 + 3 + uw_Estrings + strlen(uw_sqlsuffixString)); + + r = s2 = ctx->heap.front; + if (uw_Estrings) + *s2++ = 'E'; + *s2++ = '\''; + + for (; *s; s++) { + char c = *s; + + switch (c) { + case '\'': + if (uw_Estrings) + strcpy(s2, "\\'"); + else + strcpy(s2, "''"); + s2 += 2; + break; + case '\\': + if (uw_Estrings) { + strcpy(s2, "\\\\"); + s2 += 2; + } else + *s2++ = '\\'; + break; + default: + if (isprint((int)c)) + *s2++ = c; + else if (uw_Estrings) { + sprintf(s2, "\\%03o", (unsigned char)c); + s2 += 4; + } + else + *s2++ = c; // I hope this is safe to do... don't know how to support UTF-8 outside Postgres otherwise! + } + } + + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixString); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixString); + return r; +} + +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; + if (uw_Estrings) + *s2++ = 'E'; + *s2++ = '\''; + + switch (c) { + case '\'': + if (uw_Estrings) + strcpy(s2, "\\'"); + else + strcpy(s2, "''"); + s2 += 2; + break; + case '\\': + if (uw_Estrings) { + strcpy(s2, "\\\\"); + s2 += 2; + } else + *s2++ = '\\'; + break; + default: + if (isprint((int)c)) + *s2++ = c; + else if (uw_Estrings) { + sprintf(s2, "\\%03o", (unsigned char)c); + s2 += 4; + } + else + uw_error(ctx, FATAL, "Non-printable character %u in char to SQLify", c); + } + + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixChar); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixChar); + return r; +} + +char *uw_sqlsuffixBlob = "::bytea"; + +uw_Basis_string uw_Basis_sqlifyBlob(uw_context ctx, uw_Basis_blob b) { + char *r, *s2; + size_t i; + + uw_check_heap(ctx, b.size * 5 + 4 + strlen(uw_sqlsuffixBlob)); + + r = s2 = ctx->heap.front; + if (uw_Estrings) + *s2++ = 'E'; + else + *s2++ = 'X'; + *s2++ = '\''; + + for (i = 0; i < b.size; ++i) { + unsigned char c = b.data[i]; + + if (uw_Estrings) { + switch (c) { + case '\'': + strcpy(s2, "\\'"); + s2 += 2; + break; + case '\\': + strcpy(s2, "\\\\\\\\"); + s2 += 4; + break; + default: + if (isprint((int)c)) + *s2++ = c; + else { + sprintf(s2, "\\\\%03o", c); + s2 += 5; + } + } + } else { + sprintf(s2, "%02X", c); + s2 += 2; + } + } + + *s2++ = '\''; + strcpy(s2, uw_sqlsuffixBlob); + ctx->heap.front = s2 + 1 + strlen(uw_sqlsuffixBlob); + return r; +} + +char *uw_Basis_sqlifyChannel(uw_context ctx, uw_Basis_channel chn) { + int len; + char *r; + unsigned long long combo = ((unsigned long long)chn.cli << 32) | chn.chn; + + uw_check_heap(ctx, INTS_MAX + 7); + r = ctx->heap.front; + sprintf(r, uw_sqlfmtInt, combo, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_Basis_attrifyChannel(uw_context ctx, uw_Basis_channel chn) { + int len; + char *r; + unsigned long long combo = ((unsigned long long)chn.cli << 32) | chn.chn; + + uw_check_heap(ctx, INTS_MAX + 1); + r = ctx->heap.front; + sprintf(r, "%lld%n", combo, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_sqlfmtUint4 = "%u::int4%n"; + +char *uw_Basis_sqlifyClient(uw_context ctx, uw_Basis_client cli) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 7); + r = ctx->heap.front; + sprintf(r, uw_sqlfmtUint4, cli, &len); + ctx->heap.front += len+1; + return r; +} + +char *uw_Basis_attrifyClient(uw_context ctx, uw_Basis_client cli) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX + 1); + r = ctx->heap.front; + sprintf(r, "%u%n", cli, &len); + ctx->heap.front += len+1; + return r; +} + +uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { + if (s == NULL) + return "NULL"; + else + return uw_Basis_sqlifyString(ctx, s); +} + +char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) + return "FALSE"; + else + return "TRUE"; +} + +char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) { + if (b == NULL) + return "NULL"; + else + return uw_Basis_sqlifyBool(ctx, *b); +} + +char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r, *s; + struct tm stm = {}; + stm.tm_isdst = -1; + + if (localtime_r(&t.seconds, &stm)) { + s = uw_malloc(ctx, TIMES_MAX); + len = strftime(s, TIMES_MAX, TIME_FMT_PG, &stm); + if (uw_sql_type_annotations) { + if (t.microseconds) { + r = uw_malloc(ctx, len + 21); + sprintf(r, "'%s.%06u'::timestamp", s, t.microseconds); + } else { + r = uw_malloc(ctx, len + 14); + sprintf(r, "'%s'::timestamp", s); + } + } else { + r = uw_malloc(ctx, len + 3); + sprintf(r, "'%s'", s); + } + return r; + } else + return "<Invalid time>"; +} + +char *uw_Basis_attrifyTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm = {}; + stm.tm_isdst = -1; + + if (localtime_r(&t.seconds, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap.front; + len = strftime(r, TIMES_MAX, TIME_FMT, &stm); + ctx->heap.front += len+1; + return r; + } else + return "<Invalid time>"; +} + +char *uw_Basis_ensqlTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm = {}; + stm.tm_isdst = -1; + + if (localtime_r(&t.seconds, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap.front; + len = strftime(r, TIMES_MAX-7, TIME_FMT_PG, &stm); + ctx->heap.front += len; + sprintf(ctx->heap.front, ".%06u", t.microseconds); + ctx->heap.front += 8; + return r; + } else + return "<Invalid time>"; +} + +char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) { + if (t == NULL) + return "NULL"; + else + return uw_Basis_sqlifyTime(ctx, *t); +} + +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) + return (char *)&false; + else + return (char *)&true; +} + +uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_Basis_string uw_Basis_floatToString(uw_context ctx, uw_Basis_float n) { + int len; + char *r; + + uw_check_heap(ctx, FLOATS_MAX); + r = ctx->heap.front; + sprintf(r, "%g%n", n, &len); + ctx->heap.front += len+1; + return r; +} + +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; +} + +uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { + if (b == uw_Basis_False) + return "False"; + else + return "True"; +} + +uw_Basis_string uw_Basis_timef(uw_context ctx, const char *fmt, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm = {}; + stm.tm_isdst = -1; + + if (localtime_r(&t.seconds, &stm)) { + uw_check_heap(ctx, TIMES_MAX); + r = ctx->heap.front; + len = strftime(r, TIMES_MAX, fmt, &stm); + ctx->heap.front += len+1; + return r; + } else + return "<Invalid time>"; +} + +uw_Basis_string uw_Basis_timeToString(uw_context ctx, uw_Basis_time t) { + return uw_Basis_timef(ctx, ctx->app->time_format, t); +} + +uw_Basis_int *uw_Basis_stringToInt(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_int n = strtoll(s, &endptr, 10); + + if (*s != '\0' && *endptr == '\0') { + uw_Basis_int *r = uw_malloc(ctx, sizeof(uw_Basis_int)); + *r = n; + return r; + } else + return NULL; +} + +uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_float n = strtod(s, &endptr); + + if (*s != '\0' && *endptr == '\0') { + uw_Basis_float *r = uw_malloc(ctx, sizeof(uw_Basis_float)); + *r = n; + return r; + } else + return NULL; +} + +uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) { + if (s[0] == 0) { + uw_Basis_char *r = uw_malloc(ctx, 1); + r[0] = 0; + return r; + } else if (s[1] != 0) + return NULL; + else { + uw_Basis_char *r = uw_malloc(ctx, 1); + r[0] = s[0]; + return r; + } +} + +uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { + static uw_Basis_bool true = uw_Basis_True; + static uw_Basis_bool false = uw_Basis_False; + + if (!strcasecmp (s, "True")) + return &true; + else if (!strcasecmp (s, "False")) + return &false; + else + return NULL; +} + +uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { + char *dot = strchr(s, '.'), *end = strchr(s, 0); + struct tm stm = {}; + stm.tm_isdst = -1; + + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm) == end) { + *dot = '.'; + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } + else { + *dot = '.'; + return NULL; + } + } + else { + if (strptime(s, ctx->app->time_format, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } else if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } else if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } else if (strptime(s, TIME_FMT_JS, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } + else + return NULL; + } +} + +uw_Basis_time *uw_Basis_stringToTimef(uw_context ctx, const char *fmt, uw_Basis_string s) { + char *end = strchr(s, 0); + struct tm stm = {}; + stm.tm_isdst = -1; + + if (strptime(s, fmt, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } + else + return NULL; +} + +uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_int n = strtoll(s, &endptr, 10); + + if (*s != '\0' && *endptr == '\0') + return n; + else + uw_error(ctx, FATAL, "Can't parse int: %s", uw_Basis_htmlifyString(ctx, s)); +} + +#include <errno.h> + +uw_Basis_channel uw_Basis_stringToChannel_error(uw_context ctx, uw_Basis_string s) { + unsigned long long n; + + if (sscanf(s, "%llu", &n) < 1) + uw_error(ctx, FATAL, "Can't parse channel: %s", uw_Basis_htmlifyString(ctx, s)); + else { + uw_Basis_channel ch = {n >> 32, n & ((1ull << 32) - 1)}; + return ch; + } +} + +uw_Basis_client uw_Basis_stringToClient_error(uw_context ctx, uw_Basis_string s) { + char *endptr; + unsigned long n = strtoul(s, &endptr, 10); + + if (*s != '\0' && *endptr == '\0') + return n; + else + uw_error(ctx, FATAL, "Can't parse client: %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) { + char *endptr; + uw_Basis_float n = strtod(s, &endptr); + + if (*s != '\0' && *endptr == '\0') + return n; + else + uw_error(ctx, FATAL, "Can't parse float: %s", uw_Basis_htmlifyString(ctx, 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) + uw_error(ctx, FATAL, "Can't parse char: %s", uw_Basis_htmlifyString(ctx, s)); + else + return s[0]; +} + +uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { + if (!strcasecmp(s, "T") || !strcasecmp (s, "True")) + return uw_Basis_True; + else if (!strcasecmp(s, "F") || !strcasecmp (s, "False")) + return uw_Basis_False; + else + uw_error(ctx, FATAL, "Can't parse bool: %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_time uw_Basis_unsqlTime(uw_context ctx, uw_Basis_string s) { + char *dot = strchr(s, '.'), *end = strchr(s, 0); + struct tm stm = {}; + stm.tm_isdst = -1; + + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm)) { + *dot = '.'; + char usec[] = "000000"; + int len = strlen(dot+1); + memcpy(usec, dot+1, len < 6 ? len : 6); + uw_Basis_time r = { mktime(&stm), atoi(usec) }; + return r; + } + else { + *dot = '.'; + uw_error(ctx, FATAL, "Can't parse time: %s", uw_Basis_htmlifyString(ctx, s)); + } + } + else { + if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else + uw_error(ctx, FATAL, "Can't parse time: %s", uw_Basis_htmlifyString(ctx, s)); + } +} + +uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { + char *dot = strchr(s, '.'), *end = strchr(s, 0); + struct tm stm = {}; + stm.tm_isdst = -1; + + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm)) { + *dot = '.'; + { + uw_Basis_time r = { mktime(&stm) }; + return r; + } + } + else { + *dot = '.'; + uw_error(ctx, FATAL, "Can't parse time: %s", uw_Basis_htmlifyString(ctx, s)); + } + } + else { + if (strptime(s, ctx->app->time_format, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else if (strptime(s, TIME_FMT_JS, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else + uw_error(ctx, FATAL, "Can't parse time: %s", uw_Basis_htmlifyString(ctx, s)); + } +} + +uw_Basis_time uw_Basis_stringToTimef_error(uw_context ctx, const char *fmt, uw_Basis_string s) { + char *end = strchr(s, 0); + struct tm stm = {}; + stm.tm_isdst = -1; + + if (strptime(s, fmt, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else + uw_error(ctx, FATAL, "Can't parse time: %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_blob uw_Basis_stringToBlob_error(uw_context ctx, uw_Basis_string s, size_t len) { + char *r = ctx->heap.front; + uw_Basis_blob b = {len, r}; + + uw_check_heap(ctx, len); + + if (s[0] == '\\' && s[1] == 'x') { + s += 2; + + while (*s) { + int n; + sscanf(s, "%02x", &n); + *r++ = n; + s += 2; + } + } else { + while (*s) { + if (s[0] == '\\') { + if (s[1] == '\\') { + *r++ = '\\'; + s += 2; + } else if (isdigit((int)s[1]) && isdigit((int)s[2]) && isdigit((int)s[3])) { + *r++ = (s[1] - '0') * 8 * 8 + ((s[2] - '0') * 8) + (s[3] - '0'); + s += 4; + } + else { + *r++ = '\\'; + ++s; + } + } else { + *r++ = s[0]; + ++s; + } + } + } + + b.size = r - ctx->heap.front; + ctx->heap.front = r; + + return b; +} + +#define THE_PAST "expires=Sat, 01-Jan-2011 00:00:00 GMT" + +uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { + int len = strlen(c); + char *p = ctx->outHeaders.start; + + while ((p = strstr(p, "\nSet-Cookie: "))) { + char *p2; + p += 13; + p2 = strchr(p, '='); + + if (p2) { + size_t sz = strcspn(p2+1, ";\r\n"); + + if (!strncasecmp(p, c, p2 - p)) { + if (sz == 0 && strstr(p2+2, THE_PAST)) + return NULL; + else { + char *ret = uw_malloc(ctx, sz + 1); + memcpy(ret, p2+1, sz); + ret[sz] = 0; + return ret; + } + } + } + } + + if ((p = uw_Basis_requestHeader(ctx, "Cookie"))) { + char *p2; + + while (1) { + if (!strncmp(p, c, len) && p[len] == '=') { + if ((p2 = strchr(p, ';'))) { + size_t n = p2 - (p + len); + char *r = uw_malloc(ctx, n); + memcpy(r, p + 1 + len, n-1); + r[n-1] = 0; + return r; + } else + return p + 1 + len; + } else if ((p = strchr(p, ';'))) + p += 2; + else + return NULL; + } + } + + return NULL; +} + +static void set_cookie(uw_context ctx) { + if (ctx->usedSig) + ctx->needsResig = 1; +} + +uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure) { + uw_write_header(ctx, "Set-Cookie: "); + uw_write_header(ctx, c); + uw_write_header(ctx, "="); + uw_write_header(ctx, v); + uw_write_header(ctx, "; path="); + uw_write_header(ctx, prefix); + if (expires) { + char formatted[30]; + struct tm tm = {}; + tm.tm_isdst = -1; + + gmtime_r(&expires->seconds, &tm); + + strftime(formatted, sizeof formatted, "%a, %d-%b-%Y %T GMT", &tm); + + uw_write_header(ctx, "; expires="); + uw_write_header(ctx, formatted); + } + if (secure) + uw_write_header(ctx, "; secure"); + uw_write_header(ctx, "\r\n"); + set_cookie(ctx); + + return uw_unit_v; +} + +uw_unit uw_Basis_clear_cookie(uw_context ctx, uw_Basis_string prefix, uw_Basis_string c) { + uw_write_header(ctx, "Set-Cookie: "); + uw_write_header(ctx, c); + uw_write_header(ctx, "=; path="); + uw_write_header(ctx, prefix); + uw_write_header(ctx, "; " THE_PAST "\r\n"); + set_cookie(ctx); + + return uw_unit_v; +} + +size_t uw_deltas_max = SIZE_MAX; + +static delta *allocate_delta(uw_context ctx, unsigned client) { + unsigned i; + delta *d; + + for (i = 0; i < ctx->used_deltas; ++i) + if (ctx->deltas[i].client == client) + return &ctx->deltas[i]; + + if (ctx->used_deltas >= ctx->n_deltas) { + if (ctx->n_deltas + 1 > uw_deltas_max) + uw_error(ctx, FATAL, "Exceeded limit on number of deltas"); + + ctx->deltas = realloc(ctx->deltas, sizeof(delta) * ++ctx->n_deltas); + uw_buffer_init(uw_messages_max, &ctx->deltas[ctx->n_deltas-1].msgs, 0); + } + + d = &ctx->deltas[ctx->used_deltas++]; + d->client = client; + uw_buffer_reset(&d->msgs); + return d; +} + +uw_Basis_channel uw_Basis_new_channel(uw_context ctx, uw_unit u) { + if (ctx->client == NULL) + uw_error(ctx, FATAL, "Attempt to create channel on request not associated with a persistent connection"); + + return new_channel(ctx->client); +} + +uw_unit uw_Basis_send(uw_context ctx, uw_Basis_channel chn, uw_Basis_string msg) { + delta *d = allocate_delta(ctx, chn.cli); + size_t len; + int preLen; + char pre[INTS_MAX + 2]; + + len = strlen(msg); + + sprintf(pre, "%u\n%n", chn.chn, &preLen); + + ctx_uw_buffer_append(ctx, "messages", &d->msgs, pre, preLen); + ctx_uw_buffer_append(ctx, "messages", &d->msgs, msg, len); + ctx_uw_buffer_append(ctx, "messages", &d->msgs, "\n", 1); + + return uw_unit_v; +} + +int uw_rollback(uw_context ctx, int will_retry) { + int i; + cleanup *cl; + + if (ctx->client) + release_client(ctx->client); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].rollback != NULL) + ctx->transactionals[i].rollback(ctx->transactionals[i].data); + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, will_retry); + + if (ctx->app && ctx->transaction_started) { + ctx->transaction_started = 0; + return ctx->app->db_rollback(ctx); + } else + return 0; +} + +const char uw_begin_xhtml[] = "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">"; +const char uw_begin_html5[] = "<!DOCTYPE html><html>"; + +extern int uw_hash_blocksize; + +static const char sig_intro[] = "<input type=\"hidden\" name=\"Sig\" value=\""; + +static char *find_sig(char *haystack) { + int i; + char *s = strstr(haystack, sig_intro); + + if (!s || strlen(haystack) - (s - haystack) - (sizeof sig_intro - 1) < uw_hash_blocksize*2+1) + return NULL; + + s += sizeof sig_intro - 1; + + for (i = 0; i < uw_hash_blocksize*2; ++i) + if (!isxdigit((int)s[i])) + return NULL; + + if (s[i] != '"') + return NULL; + + return s; +} + +static pthread_mutex_t message_send_mutex = PTHREAD_MUTEX_INITIALIZER; + +int uw_commit(uw_context ctx) { + int i; + char *sig; + + if (uw_has_error(ctx)) { + uw_rollback(ctx, 0); + return 0; + } + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].rollback != NULL) + if (ctx->transactionals[i].commit) { + ctx->transactionals[i].commit(ctx->transactionals[i].data); + if (uw_has_error(ctx)) { + uw_rollback(ctx, 0); + return 0; + } + } + + // Here's an important lock to provide the abstraction that all messages from one transaction are sent as an atomic unit. + if (ctx->used_deltas > 0) + pthread_mutex_lock(&message_send_mutex); + + if (ctx->transaction_started) { + int code = ctx->app->db_commit(ctx); + + if (code) { + if (ctx->used_deltas > 0) + pthread_mutex_unlock(&message_send_mutex); + + if (ctx->client) + release_client(ctx->client); + + if (code == -1) { + // This case is for a serialization failure, which is not really an "error." + // The transaction will restart, so we should rollback any transactionals + // that triggered above. + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].rollback != NULL) + ctx->transactionals[i].rollback(ctx->transactionals[i].data); + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, 1); + + return 1; + } + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, 0); + + uw_set_error_message(ctx, "Error running SQL COMMIT"); + return 0; + } + } + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].rollback == NULL) + if (ctx->transactionals[i].commit) { + ctx->transactionals[i].commit(ctx->transactionals[i].data); + if (uw_has_error(ctx)) { + if (ctx->used_deltas > 0) + pthread_mutex_unlock(&message_send_mutex); + + if (ctx->client) + release_client(ctx->client); + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].rollback != NULL) + ctx->transactionals[i].rollback(ctx->transactionals[i].data); + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, 0); + + return 0; + } + } + + for (i = 0; i < ctx->used_deltas; ++i) { + delta *d = &ctx->deltas[i]; + client *c = find_client(d->client); + + assert (c != NULL); + assert(c->mode == USED); + + client_send(c, &d->msgs, ctx->script.start, uw_buffer_used(&ctx->script)); + } + + if (ctx->used_deltas > 0) + pthread_mutex_unlock(&message_send_mutex); + + if (ctx->client) + release_client(ctx->client); + + for (i = ctx->used_transactionals-1; i >= 0; --i) + if (ctx->transactionals[i].free) + ctx->transactionals[i].free(ctx->transactionals[i].data, 0); + + uw_check(ctx, 1); + *ctx->page.front = 0; + + if (!ctx->returning_indirectly + && (ctx->app->is_html5 + ? !strncmp(ctx->page.start, uw_begin_html5, sizeof uw_begin_html5 - 1) + : !strncmp(ctx->page.start, uw_begin_xhtml, sizeof uw_begin_xhtml - 1))) { + char *s; + + // Splice script data into appropriate part of page, also adding <head> if needed. + s = ctx->page.start + (ctx->app->is_html5 ? sizeof uw_begin_html5 - 1 : sizeof uw_begin_xhtml - 1); + s = strchr(s, '<'); + if (s == NULL) { + // Weird. Document has no tags! + + uw_write(ctx, "<head></head><body></body>"); + uw_check(ctx, 1); + *ctx->page.front = 0; + } else if (!strncmp(s, "<head>", 6)) { + // <head> is present. Let's add the <script> tags immediately after it. + + // Any freeform JavaScript to include? + if (uw_buffer_used(&ctx->script) > 0) { + size_t lenH = strlen(ctx->script_header), len = uw_buffer_used(&ctx->script); + size_t lenP = lenH + 40 + len; + char *start = s + 6, *oldPage = ctx->page.start; + + ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenP); + start += ctx->page.start - oldPage; + memmove(start + lenP, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1); + ctx->page.front += lenP; + memcpy(start, ctx->script_header, lenH); + memcpy(start + lenH, "<script type=\"text/javascript\">", 31); + memcpy(start + lenH + 31, ctx->script.start, len); + memcpy(start + lenH + 31 + len, "</script>", 9); + } else { + size_t lenH = strlen(ctx->script_header); + char *start = s + 6, *oldPage = ctx->page.start; + + ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenH); + start += ctx->page.start - oldPage; + memmove(start + lenH, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1); + ctx->page.front += lenH; + memcpy(start, ctx->script_header, lenH); + } + } else { + // No <head>. At this point, add it, with <script> tags inside. + + if (uw_buffer_used(&ctx->script) > 0) { + size_t lenH = strlen(ctx->script_header), len = uw_buffer_used(&ctx->script); + size_t lenP = lenH + 53 + len; + char *start = s, *oldPage = ctx->page.start; + + ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenP); + start += ctx->page.start - oldPage; + memmove(start + lenP, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1); + ctx->page.front += lenP; + memcpy(start, "<head>", 6); + memcpy(start + 6, ctx->script_header, lenH); + memcpy(start + 6 + lenH, "<script type=\"text/javascript\">", 31); + memcpy(start + 6 + lenH + 31, ctx->script.start, len); + memcpy(start + 6 + lenH + 31 + len, "</script></head>", 16); + } else { + size_t lenH = strlen(ctx->script_header); + size_t lenP = lenH + 13; + char *start = s, *oldPage = ctx->page.start; + + ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->page) + lenP); + start += ctx->page.start - oldPage; + memmove(start + lenP, start, uw_buffer_used(&ctx->page) - (start - ctx->page.start) + 1); + ctx->page.front += lenP; + memcpy(start, "<head>", 6); + memcpy(start + 6, ctx->script_header, lenH); + memcpy(start + 6 + lenH, "</head>", 7); + } + } + } + + if (ctx->needsResig) { + sig = find_sig(ctx->page.start); + if (sig) { + char *realsig = ctx->app->cookie_sig(ctx); + + do { + memcpy(sig, realsig, 2*uw_hash_blocksize); + sig = find_sig(sig); + } while (sig); + } + } + + return 0; +} + + +size_t uw_transactionals_max = SIZE_MAX; + +int uw_register_transactional(uw_context ctx, void *data, uw_callback commit, uw_callback rollback, + uw_callback_with_retry free) { + if (ctx->used_transactionals >= ctx->n_transactionals) { + if (ctx->used_transactionals+1 > uw_transactionals_max) + // Exceeded limit on number of transactionals. + return -1; + ctx->transactionals = realloc(ctx->transactionals, sizeof(transactional) * (ctx->used_transactionals+1)); + ++ctx->n_transactionals; + } + + ctx->transactionals[ctx->used_transactionals].data = data; + ctx->transactionals[ctx->used_transactionals].commit = commit; + ctx->transactionals[ctx->used_transactionals].rollback = rollback; + ctx->transactionals[ctx->used_transactionals++].free = free; + + return 0; +} + + +// "Garbage collection" + +void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data); +void uw_post_expunge(uw_context ctx, void *data); + +static failure_kind uw_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + int r = setjmp(ctx->jmp_buf); + + if (r == 0) + uw_do_expunge(ctx, cli, data); + else + ctx->app->db_rollback(ctx); + + uw_post_expunge(ctx, data); + + return r; +} + +void uw_prune_clients(uw_context ctx) { + client *c, *next, *prev = NULL; + time_t cutoff; + + cutoff = time(NULL) - ctx->app->timeout; + + pthread_mutex_lock(&clients_mutex); + pruning_thread = pthread_self(); + pruning_thread_initialized = 1; + + for (c = clients_used; c; c = next) { + next = c->next; + pthread_mutex_lock(&c->lock); + if (c->last_contact < cutoff && c->refcount == 0) { + failure_kind fk = UNLIMITED_RETRY; + if (prev) + prev->next = next; + else + clients_used = next; + while (fk == UNLIMITED_RETRY) { + uw_reset(ctx); + fk = uw_expunge(ctx, c->id, c->data); + if (fk == UNLIMITED_RETRY) + printf("Unlimited retry during expunge: %s\n", uw_error_message(ctx)); + } + if (fk == SUCCESS) + free_client(c); + else + fprintf(stderr, "Expunge blocked by error: %s\n", uw_error_message(ctx)); + } + else + prev = c; + pthread_mutex_unlock(&c->lock); + } + + pthread_mutex_unlock(&clients_mutex); +} + +failure_kind uw_initialize(uw_context ctx) { + int r = setjmp(ctx->jmp_buf); + + if (r == 0) { + uw_ensure_transaction(ctx); + ctx->app->initializer(ctx); + if (uw_commit(ctx)) + uw_error(ctx, FATAL, "Error running SQL COMMIT"); + } + + return r; +} + +static int url_bad(uw_Basis_string s) { + for (; *s; ++s) + if (!isgraph((int)*s)) + return 1; + + return 0; +} + +uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) { + if (url_bad(s)) + uw_error(ctx, FATAL, "Invalid URL %s", uw_Basis_htmlifyString(ctx, s)); + if (ctx->app->check_url(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed URL %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) { + if (url_bad(s)) + return NULL; + if (ctx->app->check_url(s)) + return s; + else + return NULL; +} + +static int mime_format(const char *s) { + for (; *s; ++s) + if (!isalnum((int)*s) && *s != '/' && *s != '-' && *s != '.' && *s != '+') + return 0; + + return 1; +} + +uw_Basis_string uw_Basis_blessMime(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_mime(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed MIME type %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkMime(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + return NULL; + + if (ctx->app->check_mime(s)) + return s; + else + return NULL; +} + +uw_Basis_string uw_Basis_blessRequestHeader(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + uw_error(ctx, FATAL, "Request header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_requestHeader(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed request header %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkRequestHeader(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + return NULL; + + if (ctx->app->check_requestHeader(s)) + return s; + else + return NULL; +} + +uw_Basis_string uw_Basis_blessResponseHeader(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + uw_error(ctx, FATAL, "Response header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_responseHeader(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed response header %s", uw_Basis_htmlifyString(ctx, s)); +} + +static int envVar_format(const char *s) { + for (; *s; ++s) + if (!isalnum((int)*s) && *s != '_' && *s != '.') + return 0; + + return 1; +} + +uw_Basis_string uw_Basis_checkResponseHeader(uw_context ctx, uw_Basis_string s) { + if (!envVar_format(s)) + return NULL; + + if (ctx->app->check_responseHeader(s)) + return s; + else + return NULL; +} + +uw_Basis_string uw_Basis_blessEnvVar(uw_context ctx, uw_Basis_string s) { + if (!envVar_format(s)) + uw_error(ctx, FATAL, "Environment variable \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_envVar(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed environment variable %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkEnvVar(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + return NULL; + + if (ctx->app->check_envVar(s)) + return s; + else + return NULL; +} + +static int meta_format(const char *s) { + for (; *s; ++s) + if (!isalpha((int)*s) && *s != '-') + return 0; + + return 1; +} + +uw_Basis_string uw_Basis_blessMeta(uw_context ctx, uw_Basis_string s) { + if (!meta_format(s)) + uw_error(ctx, FATAL, "Meta name \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_meta(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed meta name %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkMeta(uw_context ctx, uw_Basis_string s) { + if (!meta_format(s)) + return NULL; + + if (ctx->app->check_meta(s)) + return s; + else + return NULL; +} + +uw_Basis_string uw_Basis_getHeader(uw_context ctx, uw_Basis_string name) { + return uw_Basis_requestHeader(ctx, name); +} + +static int mime_value_format(const char *s) { + for (; *s; ++s) + if (*s == '\r' || *s == '\n') + return 0; + + return 1; +} + +uw_unit uw_Basis_setHeader(uw_context ctx, uw_Basis_string name, uw_Basis_string value) { + if (!mime_value_format(value)) + uw_error(ctx, FATAL, "Invalid value for HTTP response header"); + + uw_write_header(ctx, name); + uw_write_header(ctx, ": "); + uw_write_header(ctx, value); + uw_write_header(ctx, "\r\n"); + + return uw_unit_v; +} + +uw_Basis_string uw_Basis_getenv(uw_context ctx, uw_Basis_string name) { + if (ctx->get_env) + return ctx->get_env(ctx->get_env_data, name); + else + return getenv(name); +} + +uw_Basis_string uw_unnull(uw_Basis_string s) { + return s ? s : ""; +} + +uw_Basis_string uw_Basis_makeSigString(uw_context ctx, uw_Basis_string sig) { + uw_Basis_string r = uw_malloc(ctx, 2 * uw_hash_blocksize + 1); + int i; + + for (i = 0; i < uw_hash_blocksize; ++i) + sprintf(&r[2*i], "%.02X", ((unsigned char *)sig)[i]); + + return r; +} + +/* This bit of crafty code is intended to prevent GCC from performing + * optimizations that would enable timing attacks. See: + * http://www.impredicative.com/pipermail/ur/2011-July/000659.html + */ +int uw_streq(uw_Basis_string s1, uw_Basis_string s2) { + int i, x = 0, len1 = strlen(s1); + + if (len1 != strlen(s2)) return 0; + + for (i = 0; i < len1; ++i) { + __asm__ __volatile__ (""); + x |= s1[i] ^ s2[i]; + } + + return x == 0; +} + +uw_Basis_string uw_Basis_sigString(uw_context ctx, uw_unit u) { + ctx->usedSig = 1; + return ctx->app->cookie_sig(ctx); +} + +uw_Basis_string uw_Basis_fileName(uw_context ctx, uw_Basis_file f) { + return f.name; +} + +uw_Basis_string uw_Basis_fileMimeType(uw_context ctx, uw_Basis_file f) { + return f.type; +} + +uw_Basis_int uw_Basis_blobSize(uw_context ctx, uw_Basis_blob b) { + return b.size; +} + +uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { + uw_Basis_blob b = {strlen(s), s}; + + return b; +} + +uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { + return f.data; +} + +uw_Basis_string uw_Basis_postType(uw_context ctx, uw_Basis_postBody pb) { + return pb.type; +} + +uw_Basis_string uw_Basis_postData(uw_context ctx, uw_Basis_postBody pb) { + return pb.data; +} + +static char *old_headers(uw_context ctx) { + if (uw_buffer_used(&ctx->outHeaders) == 0) + return NULL; + else { + char *s; + int is_good; + + if (strncasecmp(ctx->outHeaders.start, "Content-type: ", 14)) { + s = strchr(ctx->outHeaders.start, '\n'); + is_good = !strncasecmp(s+1, "Content-type: ", 14); + } else { + s = ctx->outHeaders.start; + is_good = 1; + } + + if (!is_good) + return NULL; + else { + s = strchr(s+15, '\n'); + if (s == NULL) + return NULL; + else + return uw_strdup(ctx, s+1); + } + } +} + +__attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, uw_Basis_string mimeType) { + cleanup *cl; + int len; + char *oldh; + + if (!ctx->allowed_to_return_indirectly) + uw_error(ctx, FATAL, "Tried to return a blob from an RPC"); + + ctx->returning_indirectly = 1; + oldh = old_headers(ctx); + uw_buffer_reset(&ctx->outHeaders); + uw_buffer_reset(&ctx->page); + + uw_write_header(ctx, on_success); + uw_write_header(ctx, "Content-Type: "); + uw_write_header(ctx, mimeType); + uw_write_header(ctx, "\r\nContent-length: "); + ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX); + sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)b.size, &len); + ctx->outHeaders.front += len; + uw_write_header(ctx, "\r\n"); + if (oldh) uw_write_header(ctx, oldh); + + ctx_uw_buffer_append(ctx, "page", &ctx->page, b.data, b.size); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + +void uw_replace_page(uw_context ctx, const char *data, size_t size) { + uw_buffer_reset(&ctx->page); + ctx_uw_buffer_append(ctx, "page", &ctx->page, data, size); +} + +__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) { + cleanup *cl; + int len; + char *oldh; + + if (!ctx->allowed_to_return_indirectly) + uw_error(ctx, FATAL, "Tried to return a blob from an RPC"); + + ctx->returning_indirectly = 1; + oldh = old_headers(ctx); + uw_buffer_reset(&ctx->outHeaders); + + uw_write_header(ctx, on_success); + uw_write_header(ctx, "Content-Type: "); + uw_write_header(ctx, mimeType); + uw_write_header(ctx, "\r\nContent-length: "); + ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX); + sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len); + ctx->outHeaders.front += len; + uw_write_header(ctx, "\r\n"); + if (oldh) uw_write_header(ctx, oldh); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + +__attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) { + cleanup *cl; + char *s; + char *oldh; + + if (!ctx->allowed_to_return_indirectly) + uw_error(ctx, FATAL, "Tried to redirect from an RPC"); + + ctx->returning_indirectly = 1; + oldh = old_headers(ctx); + uw_buffer_reset(&ctx->page); + ctx_uw_buffer_check(ctx, "page", &ctx->page, uw_buffer_used(&ctx->outHeaders)+1); + memcpy(ctx->page.start, ctx->outHeaders.start, uw_buffer_used(&ctx->outHeaders)); + ctx->page.start[uw_buffer_used(&ctx->outHeaders)] = 0; + uw_buffer_reset(&ctx->outHeaders); + + if (on_success[0]) + uw_write_header(ctx, on_redirect); + else + uw_write_header(ctx, "Status: 303 See Other\r\n"); + s = on_success[0] ? strchr(ctx->page.start, '\n') : ctx->page.start; + if (s) { + char *s2; + if (s[0] == '\n') ++s; + for (; (s2 = strchr(s, '\n')); s = s2+1) { + *s2 = 0; + if (!strncmp(s, "Set-Cookie: ", 12)) { + uw_write_header(ctx, s); + uw_write_header(ctx, "\n"); + } + } + } + + uw_write_header(ctx, "Location: "); + uw_write_header(ctx, url); + uw_write_header(ctx, "\r\n\r\n"); + if (oldh) uw_write_header(ctx, oldh); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + +uw_Basis_string uw_Basis_unAs(uw_context ctx, uw_Basis_string s) { + uw_Basis_string ret = uw_malloc(ctx, strlen(s) + 1), r = ret; + + for (; *s; ++s) { + if (s[0] == '\'') { + *r++ = '\''; + for (++s; *s; ++s) { + if (s[0] == '\'') { + *r++ = '\''; + break; + } else if (s[0] == '\\') { + *r++ = '\\'; + *r++ = s[1]; + ++s; + } else + *r++ = s[0]; + } + if (*s == 0) break; + } else if (s[0] == 'T' && s[1] == '_' && s[2] == 'T' && s[3] == '.') + s += 3; + else + *r++ = s[0]; + } + + *r = 0; + return ret; +} + +uw_Basis_string uw_Basis_mstrcat(uw_context ctx, ...) { + va_list ap; + size_t len = 1; + char *s, *r, *s2; + + va_start(ap, ctx); + for (s = va_arg(ap, char*); s; s = va_arg(ap, char*)) + len += strlen(s); + va_end(ap); + + r = uw_malloc(ctx, len); + va_start(ap, ctx); + for (s2 = r, s = va_arg(ap, char*); s; s = va_arg(ap, char*)) + while (*s) + *s2++ = *s++; + va_end(ap); + *s2 = 0; + + return r; +} + +const uw_Basis_time uw_Basis_minTime = {}; + +uw_Basis_time uw_Basis_now(uw_context ctx) { + uw_Basis_time r = { time(NULL) }; + return r; +} + +uw_Basis_time uw_Basis_addSeconds(uw_context ctx, uw_Basis_time tm, uw_Basis_int n) { + tm.seconds += n; + return tm; +} + +uw_Basis_int uw_Basis_diffInSeconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) { + return difftime(tm2.seconds, tm1.seconds); +} + +uw_Basis_int uw_Basis_toMilliseconds(uw_context ctx, uw_Basis_time tm) { + return tm.seconds * 1000 + tm.microseconds / 1000; +} + +uw_Basis_time uw_Basis_fromMilliseconds(uw_context ctx, uw_Basis_int n) { + uw_Basis_time tm = {n / 1000, n % 1000 * 1000}; + return tm; +} + +uw_Basis_int uw_Basis_diffInMilliseconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) { + return uw_Basis_toMilliseconds(ctx, tm2) - uw_Basis_toMilliseconds(ctx, tm1); +} + +uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) { + return tm.seconds; +} + +uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) { + 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) }; + return r; +} + +uw_Basis_int uw_Basis_datetimeYear(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_year + 1900; +} + +uw_Basis_int uw_Basis_datetimeMonth(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_mon; +} + +uw_Basis_int uw_Basis_datetimeDay(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_mday; +} + +uw_Basis_int uw_Basis_datetimeHour(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_hour; +} + +uw_Basis_int uw_Basis_datetimeMinute(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_min; +} + +uw_Basis_int uw_Basis_datetimeSecond(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_sec; +} + +uw_Basis_int uw_Basis_datetimeDayOfWeek(uw_context ctx, uw_Basis_time time) { + struct tm tm; + localtime_r(&time.seconds, &tm); + return tm.tm_wday; +} + + +void *uw_get_global(uw_context ctx, char *name) { + int i; + + for (i = 0; i < ctx->n_globals; ++i) + if (!strcmp(name, ctx->globals[i].name)) + return ctx->globals[i].data; + + return NULL; +} + +size_t uw_globals_max = SIZE_MAX; + +void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*)) { + int i; + + for (i = 0; i < ctx->n_globals; ++i) + if (!strcmp(name, ctx->globals[i].name)) { + if (ctx->globals[i].free) + ctx->globals[i].free(ctx->globals[i].data); + ctx->globals[i].data = data; + ctx->globals[i].free = free; + return; + } + + if (ctx->n_globals+1 > uw_globals_max) + uw_error(ctx, FATAL, "Exceeded limit on number of globals"); + + ++ctx->n_globals; + ctx->globals = realloc(ctx->globals, ctx->n_globals * sizeof(global)); + ctx->globals[ctx->n_globals-1].name = name; + ctx->globals[ctx->n_globals-1].data = data; + ctx->globals[ctx->n_globals-1].free = free; +} + +uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) { + return !!isalnum((int)c); +} + +uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) { + return !!isalpha((int)c); +} + +uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) { + return !!isblank((int)c); +} + +uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) { + return !!iscntrl((int)c); +} + +uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) { + return !!isdigit((int)c); +} + +uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) { + return !!isgraph((int)c); +} + +uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) { + return !!islower((int)c); +} + +uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) { + return !!isprint((int)c); +} + +uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) { + return !!ispunct((int)c); +} + +uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) { + return !!isspace((int)c); +} + +uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) { + return !!isupper((int)c); +} + +uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) { + return !!isxdigit((int)c); +} + +uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) { + return tolower((int)c); +} + +uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) { + return toupper((int)c); +} + +uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) { + return (unsigned char)c; +} + +uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { + return n; +} + +uw_Basis_string uw_Basis_currentUrl(uw_context ctx) { + return ctx->current_url; +} + +void uw_set_currentUrl(uw_context ctx, char *s) { + ctx->current_url = s; +} + +void uw_set_deadline(uw_context ctx, int n) { + ctx->deadline = n; +} + +void uw_check_deadline(uw_context ctx) { + if (uw_time > ctx->deadline) + uw_error(ctx, FATAL, "Maximum running time exceeded"); +} + +size_t uw_database_max = SIZE_MAX; + +uw_Basis_int uw_Basis_naughtyDebug(uw_context ctx, uw_Basis_string s) { + if (ctx->loggers->log_debug) + ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s); + else + fprintf(stderr, "%s\n", s); + return 0; +} + +uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { + if (ctx->loggers->log_debug) + ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s); + else + fprintf(stderr, "%s\n", s); + return uw_unit_v; +} + +uw_Basis_int uw_Basis_rand(uw_context ctx) { + int r = my_rand(); + + if (r >= 0) + return r; + else + uw_error(ctx, FATAL, "Random number generation failed"); +} + +void uw_noPostBody(uw_context ctx) { + ctx->hasPostBody = 0; +} + +void uw_postBody(uw_context ctx, uw_Basis_postBody pb) { + ctx->hasPostBody = 1; + ctx->postBody = pb; +} + +int uw_hasPostBody(uw_context ctx) { + return ctx->hasPostBody; +} + +void uw_isPost(uw_context ctx) { + ctx->isPost = 1; +} + +uw_Basis_bool uw_Basis_currentUrlHasPost(uw_context ctx) { + return ctx->isPost; +} + +uw_Basis_bool uw_Basis_currentUrlHasQueryString(uw_context ctx) { + return ctx->queryString != NULL && ctx->queryString[0] != 0; +} + +void uw_setQueryString(uw_context ctx, uw_Basis_string s) { + ctx->queryString = s; +} + +uw_Basis_string uw_queryString(uw_context ctx) { + return ctx->queryString; +} + +uw_Basis_postBody uw_getPostBody(uw_context ctx) { + if (ctx->hasPostBody) + return ctx->postBody; + else + uw_error(ctx, FATAL, "Asked for POST body when none exists"); +} + +failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) { + int r = setjmp(ctx->jmp_buf); + + if (r == 0) { + uw_ensure_transaction(ctx); + + callback(ctx); + } + + return r; +} + +uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) { + char buf[14]; + return uw_strdup(ctx, DES_fcrypt(key, salt, buf)); +} + +uw_Basis_bool uw_Basis_eq_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) { + return !!(t1.seconds == t2.seconds && t1.microseconds == t2.microseconds); +} + +uw_Basis_bool uw_Basis_lt_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) { + return !!(t1.seconds < t2.seconds || (t1.seconds == t2.seconds && t1.microseconds < t2.microseconds)); +} + +uw_Basis_bool uw_Basis_le_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) { + return !!(uw_Basis_eq_time(ctx, t1, t2) || uw_Basis_lt_time(ctx, t1, t2)); +} + +uw_Basis_time *uw_Basis_readUtc(uw_context ctx, uw_Basis_string s) { + struct tm stm = {}; + char *end = strchr(s, 0); + stm.tm_isdst = -1; + + if (strptime(s, TIME_FMT_PG, &stm) == end || strptime(s, TIME_FMT, &stm) == end || strptime(s, TIME_FMT_JS, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + + r->seconds = timegm(&stm); + r->microseconds = 0; + + return r; + } + else + return NULL; +} + +failure_kind uw_begin_onError(uw_context ctx, char *msg) { + int r = setjmp(ctx->jmp_buf); + + if (ctx->app->on_error) { + if (r == 0) { + uw_ensure_transaction(ctx); + + uw_buffer_reset(&ctx->outHeaders); + if (on_success[0]) + uw_write_header(ctx, "HTTP/1.1 "); + else + uw_write_header(ctx, "Status: "); + uw_write_header(ctx, "500 Internal Server Error\r\n"); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, ctx->app->is_html5 ? uw_begin_html5 : uw_begin_xhtml); + ctx->app->on_error(ctx, msg); + uw_write(ctx, "</html>"); + } + + return r; + } else + uw_error(ctx, FATAL, "Tried to run nonexistent onError handler"); +} + +void uw_mayReturnIndirectly(uw_context ctx) { + ctx->allowed_to_return_indirectly = 1; +} + +uw_Basis_string uw_Basis_fresh(uw_context ctx) { + int len; + char *r; + + uw_check_heap(ctx, 2+INTS_MAX); + r = ctx->heap.front; + sprintf(r, "uw%u%n", ctx->nextId++, &len); + ctx->heap.front += len+1; + return r; +} + +uw_Basis_float uw_Basis_floatFromInt(uw_context ctx, uw_Basis_int n) { + return n; +} + +uw_Basis_int uw_Basis_ceil(uw_context ctx, uw_Basis_float n) { + return ceil(n); +} + +uw_Basis_int uw_Basis_trunc(uw_context ctx, uw_Basis_float n) { + return trunc(n); +} + +uw_Basis_int uw_Basis_round(uw_context ctx, uw_Basis_float n) { + return round(n); +} + +uw_Basis_int uw_Basis_floor(uw_context ctx, uw_Basis_float n) { + return floor(n); +} + +uw_Basis_float uw_Basis_pow(uw_context ctx, uw_Basis_float n, uw_Basis_float m) { + return pow(n,m); +} + +uw_Basis_float uw_Basis_sqrt(uw_context ctx, uw_Basis_float n) { + return sqrt(n); +} + +uw_Basis_float uw_Basis_sin(uw_context ctx, uw_Basis_float n) { + return sin(n); +} + +uw_Basis_float uw_Basis_cos(uw_context ctx, uw_Basis_float n) { + return cos(n); +} + +uw_Basis_float uw_Basis_log(uw_context ctx, uw_Basis_float n) { + return log(n); +} + +uw_Basis_float uw_Basis_exp(uw_context ctx, uw_Basis_float n) { + return exp(n); +} + +uw_Basis_float uw_Basis_asin(uw_context ctx, uw_Basis_float n) { + return asin(n); +} + +uw_Basis_float uw_Basis_acos(uw_context ctx, uw_Basis_float n) { + return acos(n); +} + +uw_Basis_float uw_Basis_atan(uw_context ctx, uw_Basis_float n) { + return atan(n); +} + +uw_Basis_float uw_Basis_atan2(uw_context ctx, uw_Basis_float n, uw_Basis_float m) { + return atan2(n, m); +} + +uw_Basis_float uw_Basis_abs(uw_context ctx, uw_Basis_float n) { + return fabs(n); +} + +uw_Basis_string uw_Basis_atom(uw_context ctx, uw_Basis_string s) { + char *p; + + for (p = s; *p; ++p) { + char c = *p; + if (!isalnum((int)c) && c != '+' && c != '-' && c != '.' && c != '%' && c != '#') + uw_error(ctx, FATAL, "Disallowed character in CSS atom"); + } + + return s; +} + +uw_Basis_string uw_Basis_css_url(uw_context ctx, uw_Basis_string s) { + char *p; + + for (p = s; *p; ++p) { + char c = *p; + if (!isalnum((int)c) && c != ':' && c != '/' && c != '.' && c != '_' && c != '+' + && c != '-' && c != '%' && c != '?' && c != '&' && c != '=' && c != '#') + uw_error(ctx, FATAL, "Disallowed character in CSS URL"); + } + + return s; +} + +uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) { + char *p; + + if (!*s) + uw_error(ctx, FATAL, "Empty CSS property"); + + if (!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 != '-') + uw_error(ctx, FATAL, "Disallowed character in CSS property"); + } + + return s; +} + +uw_Basis_string uw_Basis_fieldName(uw_context ctx, uw_Basis_postField f) { + return f.name; +} + +uw_Basis_string uw_Basis_fieldValue(uw_context ctx, uw_Basis_postField f) { + return f.value; +} + +uw_Basis_string uw_Basis_remainingFields(uw_context ctx, uw_Basis_postField f) { + return f.remaining; +} + +uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) { + char *unurl; + uw_Basis_postField *f; + + if (!ctx->hasPostBody) + uw_error(ctx, FATAL, "firstFormField called when there is no POST body"); + + if (s < ctx->postBody.data || s >= ctx->postBody.data + ctx->postBody.len) + return NULL; + + f = uw_malloc(ctx, sizeof(uw_Basis_postField)); + unurl = s; + f->name = uw_Basis_unurlifyString(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); + s = strchr(s, 0); + if (!s) + uw_error(ctx, FATAL, "firstFormField: Missing null terminator"); + f->remaining = s+1; + + return f; +} + +uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) { + char *p = s; + + for (; *p; ++p) + if (!isalnum(*p) && *p != '-' && *p != '_') + uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s); + + return s; +} + +int uw_remoteSock(uw_context ctx) { + return ctx->remoteSock; +} + +void uw_set_remoteSock(uw_context ctx, int sock) { + ctx->remoteSock = sock; +} + + +// Sqlcache + +static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) { + if (value) { + free(value->result); + free(value->output); + free(value->scriptOutput); + free(value); + } +} + +static void uw_Sqlcache_freeEntry(uw_Sqlcache_Entry* entry) { + if (entry) { + free(entry->key); + uw_Sqlcache_freeValue(entry->value); + free(entry); + } +} + +// TODO: pick a number. +static unsigned int uw_Sqlcache_maxSize = 1234567890; + +static void uw_Sqlcache_delete(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry) { + if (entry) { + HASH_DEL(cache->table, entry); + uw_Sqlcache_freeEntry(entry); + } +} + +static uw_Sqlcache_Entry *uw_Sqlcache_find(uw_Sqlcache_Cache *cache, char *key, size_t len, int bump) { + uw_Sqlcache_Entry *entry = NULL; + HASH_FIND(hh, cache->table, key, len, entry); + if (entry && bump) { + // Bump for LRU purposes. + HASH_DEL(cache->table, entry); + // Important that we use [entry->key], because [key] might be ephemeral. + HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry); + } + return entry; +} + +static void uw_Sqlcache_add(uw_Sqlcache_Cache *cache, uw_Sqlcache_Entry *entry, size_t len) { + HASH_ADD_KEYPTR(hh, cache->table, entry->key, len, entry); + if (HASH_COUNT(cache->table) > uw_Sqlcache_maxSize) { + // Deletes the first element of the cache. + uw_Sqlcache_delete(cache, cache->table); + } +} + +static unsigned long uw_Sqlcache_getTimeNow(uw_Sqlcache_Cache *cache) { + // TODO: verify that this makes time comparisons do the Right Thing. + return cache->timeNow++; +} + +static unsigned long uw_Sqlcache_timeMax(unsigned long x, unsigned long y) { + return x > y ? x : y; +} + +static char uw_Sqlcache_keySep = '_'; + +static char *uw_Sqlcache_allocKeyBuffer(char **keys, size_t numKeys) { + size_t len = 0; + while (numKeys-- > 0) { + char* k = keys[numKeys]; + if (!k) { + // Can only happen when flushing, in which case we don't need anything past the null key. + break; + } + // Leave room for separator. + len += 1 + strlen(k); + } + char *buf = malloc(len+1); + // If nothing is copied into the buffer, it should look like it has length 0. + buf[0] = 0; + return buf; +} + +static char *uw_Sqlcache_keyCopy(char *buf, char *key) { + *buf++ = uw_Sqlcache_keySep; + return stpcpy(buf, key); +} + +// The NUL-terminated prefix of [key] below always looks something like "_k1_k2_k3..._kn". + +uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + int doBump = random() % 1024 == 0; + if (doBump) { + pthread_rwlock_wrlock(&cache->lockIn); + } else { + pthread_rwlock_rdlock(&cache->lockIn); + } + size_t numKeys = cache->numKeys; + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + time_t timeInvalid = cache->timeInvalid; + uw_Sqlcache_Entry *entry = NULL; + if (numKeys == 0) { + entry = cache->table; + if (!entry) { + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return NULL; + } + } else { + while (numKeys-- > 0) { + buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]); + size_t len = buf - key; + entry = uw_Sqlcache_find(cache, key, len, doBump); + if (!entry) { + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return NULL; + } + timeInvalid = uw_Sqlcache_timeMax(timeInvalid, entry->timeInvalid); + } + free(key); + } + uw_Sqlcache_Value *value = entry->value; + pthread_rwlock_unlock(&cache->lockIn); + // ASK: though the argument isn't trivial, this is safe, right? + // Returning outside the lock is safe because updates happen at commit time. + // Those are the only times the returned value or its strings can get freed. + // Handler output is a new string, so it's safe to free this at commit time. + return value && timeInvalid < value->timeValid ? value : NULL; +} + +static void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) { + pthread_rwlock_wrlock(&cache->lockIn); + size_t numKeys = cache->numKeys; + time_t timeNow = uw_Sqlcache_getTimeNow(cache); + uw_Sqlcache_Entry *entry = NULL; + if (numKeys == 0) { + entry = cache->table; + if (!entry) { + entry = calloc(1, sizeof(uw_Sqlcache_Entry)); + entry->key = NULL; + entry->value = NULL; + entry->timeInvalid = 0; + cache->table = entry; + } + } else { + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + while (numKeys-- > 0) { + buf = uw_Sqlcache_keyCopy(buf, keys[numKeys]); + size_t len = buf - key; + + entry = uw_Sqlcache_find(cache, key, len, 1); + if (!entry) { + entry = calloc(1, sizeof(uw_Sqlcache_Entry)); + entry->key = strdup(key); + entry->value = NULL; + entry->timeInvalid = 0; + uw_Sqlcache_add(cache, entry, len); + } + } + free(key); + } + if (!entry->value || entry->value->timeValid < value->timeValid) { + uw_Sqlcache_freeValue(entry->value); + entry->value = value; + entry->value->timeValid = timeNow; + } + pthread_rwlock_unlock(&cache->lockIn); +} + +static void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) { +} + +static void uw_Sqlcache_commit(void *data) { + uw_context ctx = (uw_context)data; + uw_Sqlcache_Update *update = ctx->cacheUpdate; + while (update) { + uw_Sqlcache_Cache *cache = update->cache; + char **keys = update->keys; + if (update->value) { + uw_Sqlcache_storeCommitOne(cache, keys, update->value); + } else { + uw_Sqlcache_flushCommitOne(cache, keys); + } + update = update->next; + } +} + +static void uw_Sqlcache_free(void *data, int dontCare) { + uw_context ctx = (uw_context)data; + uw_Sqlcache_Update *update = ctx->cacheUpdate; + while (update) { + char** keys = update->keys; + size_t numKeys = update->cache->numKeys; + while (numKeys-- > 0) { + free(keys[numKeys]); + } + free(keys); + // Don't free [update->value]: it's in the cache now! + uw_Sqlcache_Update *nextUpdate = update->next; + free(update); + update = nextUpdate; + } + ctx->cacheUpdate = NULL; + ctx->cacheUpdateTail = NULL; + uw_Sqlcache_Unlock *unlock = ctx->cacheUnlock; + while (unlock) { + pthread_rwlock_unlock(unlock->lock); + uw_Sqlcache_Unlock *nextUnlock = unlock->next; + free(unlock); + unlock = nextUnlock; + } + ctx->cacheUnlock = NULL; +} + +static void uw_Sqlcache_pushUnlock(uw_context ctx, pthread_rwlock_t *lock) { + if (!ctx->cacheUnlock) { + // Just need one registered commit for both updating and unlocking. + uw_register_transactional(ctx, ctx, uw_Sqlcache_commit, NULL, uw_Sqlcache_free); + } + uw_Sqlcache_Unlock *unlock = malloc(sizeof(uw_Sqlcache_Unlock)); + unlock->lock = lock; + unlock->next = ctx->cacheUnlock; + ctx->cacheUnlock = unlock; +} + +void uw_Sqlcache_rlock(uw_context ctx, uw_Sqlcache_Cache *cache) { + pthread_rwlock_rdlock(&cache->lockOut); + uw_Sqlcache_pushUnlock(ctx, &cache->lockOut); +} + +void uw_Sqlcache_wlock(uw_context ctx, uw_Sqlcache_Cache *cache) { + pthread_rwlock_wrlock(&cache->lockOut); + uw_Sqlcache_pushUnlock(ctx, &cache->lockOut); +} + +static char **uw_Sqlcache_copyKeys(char **keys, size_t numKeys) { + char **copy = malloc(sizeof(char *) * numKeys); + while (numKeys-- > 0) { + char *k = keys[numKeys]; + copy[numKeys] = k ? strdup(k) : NULL; + } + return copy; +} + +void uw_Sqlcache_store(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys, uw_Sqlcache_Value *value) { + uw_Sqlcache_Update *update = malloc(sizeof(uw_Sqlcache_Update)); + update->cache = cache; + update->keys = uw_Sqlcache_copyKeys(keys, cache->numKeys); + update->value = value; + update->next = NULL; + // Can't use [uw_Sqlcache_getTimeNow] because it modifies state and we don't have the lock. + pthread_rwlock_rdlock(&cache->lockIn); + value->timeValid = cache->timeNow; + pthread_rwlock_unlock(&cache->lockIn); + if (ctx->cacheUpdateTail) { + ctx->cacheUpdateTail->next = update; + } else { + ctx->cacheUpdate = update; + } + ctx->cacheUpdateTail = update; +} + +void uw_Sqlcache_flush(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + // A flush has to happen immediately so that subsequent stores in the same transaction fail. + // This is safe to do because we will always call [uw_Sqlcache_wlock] earlier. + // If the transaction fails, the only harm done is a few extra cache misses. + pthread_rwlock_wrlock(&cache->lockIn); + size_t numKeys = cache->numKeys; + if (numKeys == 0) { + uw_Sqlcache_Entry *entry = cache->table; + if (entry) { + uw_Sqlcache_freeValue(entry->value); + entry->value = NULL; + } + } else { + char *key = uw_Sqlcache_allocKeyBuffer(keys, numKeys); + char *buf = key; + time_t timeNow = uw_Sqlcache_getTimeNow(cache); + while (numKeys-- > 0) { + char *k = keys[numKeys]; + if (!k) { + size_t len = buf - key; + if (len == 0) { + // The first key was null. + cache->timeInvalid = timeNow; + } else { + uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0); + if (entry) { + entry->timeInvalid = timeNow; + } + } + free(key); + pthread_rwlock_unlock(&cache->lockIn); + return; + } + buf = uw_Sqlcache_keyCopy(buf, k); + } + // All the keys were non-null, so we delete the pointed-to entry. + size_t len = buf - key; + uw_Sqlcache_Entry *entry = uw_Sqlcache_find(cache, key, len, 0); + free(key); + uw_Sqlcache_delete(cache, entry); + } + pthread_rwlock_unlock(&cache->lockIn); +} + +int strcmp_nullsafe(const char *str1, const char *str2) { + if (str1) + return strcmp(str1, str2); + else + return 1; +} diff --git a/src/cache.sml b/src/cache.sml new file mode 100644 index 0000000..015c3ff --- /dev/null +++ b/src/cache.sml @@ -0,0 +1,17 @@ +structure Cache = struct + +type cache = + {(* Takes a query ID and parameters (and, for store, the value to + store) and gives an FFI call that checks, stores, or flushes the + relevant entry. The parameters are strings for check and store and + optional strings for flush because some parameters might not be + fixed. *) + check : int * Mono.exp list -> Mono.exp', + store : int * Mono.exp list * Mono.exp -> Mono.exp', + flush : int * Mono.exp list -> Mono.exp', + lock : int * bool (* true = write, false = read *) -> Mono.exp', + (* Generates C needed for FFI calls in check, store, and flush. *) + setupGlobal : Print.PD.pp_desc, + setupQuery : {index : int, params : int} -> Print.PD.pp_desc} + +end diff --git a/src/cgi.sig b/src/cgi.sig new file mode 100644 index 0000000..ae6549a --- /dev/null +++ b/src/cgi.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 CGI = sig + +end diff --git a/src/cgi.sml b/src/cgi.sml new file mode 100644 index 0000000..7ee8142 --- /dev/null +++ b/src/cgi.sml @@ -0,0 +1,52 @@ +(* 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 Cgi :> CGI = struct + +open Settings +open Print.PD Print + +val () = addProtocol {name = "cgi", + compile = "", + linkStatic = "liburweb_cgi.a", + linkDynamic = "-lurweb_cgi", + persistent = false, + code = fn () => box [string "void uw_global_custom() {", + case getSigFile () of + NONE => box [] + | SOME sf => box [string "extern char *uw_sig_file;", + newline, + string "uw_sig_file = \"", + string sf, + string "\";", + newline], + string "uw_setup_limits();", + newline, + string "}", + newline]} + +end diff --git a/src/checknest.sig b/src/checknest.sig new file mode 100644 index 0000000..f8273b4 --- /dev/null +++ b/src/checknest.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, 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 CHECKNEST = sig + + val annotate : Cjr.file -> Cjr.file + +end diff --git a/src/checknest.sml b/src/checknest.sml new file mode 100644 index 0000000..fa418d8 --- /dev/null +++ b/src/checknest.sml @@ -0,0 +1,187 @@ +(* Copyright (c) 2009, 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 Checknest :> CHECKNEST = struct + +open Cjr + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun expUses globals = + let + fun eu (e, _) = + case e of + EPrim _ => IS.empty + | ERel _ => IS.empty + | ENamed n => Option.getOpt (IM.find (globals, n), IS.empty) + | ECon (_, _, NONE) => IS.empty + | ECon (_, _, SOME e) => eu e + | ENone _ => IS.empty + | ESome (_, e) => eu e + | EFfi _ => IS.empty + | EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es) + | EApp (e, es) => foldl IS.union (eu e) (map eu es) + + | EUnop (_, e) => eu e + | EBinop (_, e1, e2) => IS.union (eu e1, eu e2) + + | ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes + | EField (e, _) => eu e + + | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes + + | EError (e, _) => eu e + | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType + | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType) + | ERedirect (e, _) => eu e + + | EWrite e => eu e + | ESeq (e1, e2) => IS.union (eu e1, eu e2) + | ELet (_, _, e1, e2) => IS.union (eu e1, eu e2) + + | EQuery {query, body, initial, prepared, ...} => + let + val s = IS.union (eu query, IS.union (eu body, eu initial)) + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + | EDml {dml, prepared, ...} => + let + val s = eu dml + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + | ENextval {seq, prepared, ...} => + let + val s = eu seq + in + case prepared of + SOME {id, ...} => IS.add (s, id) + | _ => s + end + | ESetval {seq, count} => IS.union (eu seq, eu count) + + | EUnurlify (e, _, _) => eu e + in + eu + end + +fun annotateExp globals = + let + fun ae (e as (_, loc)) = + case #1 e of + EPrim _ => e + | ERel _ => e + | ENamed n => e + | ECon (_, _, NONE) => e + | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc) + | ENone _ => e + | ESome (t, e) => (ESome (t, ae e), loc) + | EFfi _ => e + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc) + | EApp (e, es) => (EApp (ae e, map ae es), loc) + + | EUnop (uo, e) => (EUnop (uo, ae e), loc) + | EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc) + + | ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc) + | EField (e, f) => (EField (ae e, f), loc) + + | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc) + + | EError (e, t) => (EError (ae e, t), loc) + | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc) + | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc) + | ERedirect (e, t) => (ERedirect (ae e, t), loc) + + | EWrite e => (EWrite (ae e), loc) + | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc) + + | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => + (EQuery {exps = exps, + tables = tables, + rnum = rnum, + state = state, + query = ae query, + body = ae body, + initial = ae initial, + prepared = case prepared of + NONE => NONE + | SOME {id, query, ...} => SOME {id = id, query = query, + nested = IS.member (expUses globals body, id)}}, + loc) + | EDml {dml, prepared, mode} => + (EDml {dml = ae dml, + prepared = prepared, + mode = mode}, loc) + + | ENextval {seq, prepared} => + (ENextval {seq = ae seq, + prepared = prepared}, loc) + | ESetval {seq, count} => + (ESetval {seq = ae seq, + count = ae count}, loc) + + | EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc) + in + ae + end + +fun annotate (ds, syms) = + let + val globals = + foldl (fn ((d, _), globals) => + case d of + DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e) + | DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e) + | DFunRec fs => + let + val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs + in + foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs + end + | _ => globals) IM.empty ds + + val ds = + map (fn d as (_, loc) => + case #1 d of + DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc) + | DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc) + | DFunRec fs => (DFunRec + (map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc) + | _ => d) ds + in + (ds, syms) + end + +end diff --git a/src/cjr.sml b/src/cjr.sml new file mode 100644 index 0000000..e582e6a --- /dev/null +++ b/src/cjr.sml @@ -0,0 +1,138 @@ +(* Copyright (c) 2008, 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 Cjr = struct + +type 'a located = 'a ErrorMsg.located + +datatype datatype_kind = datatype DatatypeKind.datatype_kind + +datatype typ' = + TFun of typ * typ + | TRecord of int + | TDatatype of datatype_kind * int * (string * int * typ option) list ref + | TFfi of string * string + | TOption of typ + | TList of typ * int + +withtype typ = typ' located + +datatype patCon = + PConVar of int + | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} + +datatype pat' = + PVar of string * typ + | PPrim of Prim.t + | PCon of datatype_kind * patCon * pat option + | PRecord of (string * pat * typ) list + | PNone of typ + | PSome of typ * pat + +withtype pat = pat' located + +datatype failure_mode = datatype Settings.failure_mode + +datatype exp' = + EPrim of Prim.t + | ERel of int + | ENamed of int + | ECon of datatype_kind * patCon * exp option + | ENone of typ + | ESome of typ * exp + | EFfi of string * string + | EFfiApp of string * string * (exp * typ) list + | EApp of exp * exp list + + | EUnop of string * exp + | EBinop of string * exp * exp + + | ERecord of int * (string * exp) list + | EField of exp * string + + | ECase of exp * (pat * exp) list * { disc : typ, result : typ } + + | EError of exp * typ + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} + | ERedirect of exp * typ + + | EWrite of exp + | ESeq of exp * exp + | ELet of string * typ * exp * exp + + | EQuery of { exps : (string * typ) list, + tables : (string * (string * typ) list) list, + rnum : int, + state : typ, + query : exp, + body : exp, + initial : exp, + prepared : {id : int, query : string, nested : bool} option } + | EDml of { dml : exp, + prepared : {id : int, dml : string} option, + mode : failure_mode } + | ENextval of { seq : exp, + prepared : {id : int, query : string} option } + | ESetval of { seq : exp, count : exp } + | EUnurlify of exp * typ * bool + +withtype exp = exp' located + +datatype task = Initialize | ClientLeaves | Periodic of Int64.int + +datatype decl' = + DStruct of int * (string * typ) list + | DDatatype of (datatype_kind * string * int * (string * int * typ option) list) list + | DDatatypeForward of datatype_kind * string * int + | DVal of string * int * typ * exp + | DFun of string * int * (string * typ) list * typ * exp + | DFunRec of (string * int * (string * typ) list * typ * exp) list + + | 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} + | DPreparedStatements of (string * int) list + + | DJavaScript of string + | DCookie of string + | DStyle of string + + | DTask of task * string (* first arg name *) * string * exp + | DOnError of int + +withtype decl = decl' located + +datatype sidedness = datatype Mono.sidedness +datatype dbmode = datatype Mono.dbmode + +datatype effect = datatype Export.effect +datatype export_kind = datatype Export.export_kind + +type file = decl list * (export_kind * string * int * typ list * typ * sidedness * dbmode * bool) list + +end diff --git a/src/cjr_env.sig b/src/cjr_env.sig new file mode 100644 index 0000000..0254f15 --- /dev/null +++ b/src/cjr_env.sig @@ -0,0 +1,59 @@ +(* Copyright (c) 2008, 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 CJR_ENV = sig + + type env + + val empty : env + + exception UnboundRel of int + exception UnboundNamed of int + exception UnboundF of int + exception UnboundStruct of int + + val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env + val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list + + val lookupConstructor : env -> int -> string * Cjr.typ option * int + + val pushERel : env -> string -> Cjr.typ -> env + val lookupERel : env -> int -> string * Cjr.typ + val listERels : env -> (string * Cjr.typ) list + val countERels : env -> int + + val pushENamed : env -> string -> int -> Cjr.typ -> env + val lookupENamed : env -> int -> string * Cjr.typ + + val pushStruct : env -> int -> (string * Cjr.typ) list -> env + val lookupStruct : env -> int -> (string * Cjr.typ) list + + val declBinds : env -> Cjr.decl -> env + + val classifyDatatype : (string * int * Cjr.typ option) list -> Cjr.datatype_kind + +end diff --git a/src/cjr_env.sml b/src/cjr_env.sml new file mode 100644 index 0000000..21188b5 --- /dev/null +++ b/src/cjr_env.sml @@ -0,0 +1,177 @@ +(* Copyright (c) 2008, 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 CjrEnv :> CJR_ENV = struct + +open Cjr + +structure IM = IntBinaryMap + + +exception UnboundRel of int +exception UnboundNamed of int +exception UnboundF of int +exception UnboundStruct of int + +type env = { + datatypes : (string * (string * int * typ option) list) IM.map, + constructors : (string * typ option * int) IM.map, + + numRelE : int, + relE : (string * typ) list, + namedE : (string * typ) IM.map, + + structs : (string * typ) list IM.map +} + +val empty : env = { + datatypes = IM.empty, + constructors = IM.empty, + + numRelE = 0, + relE = [], + namedE = IM.empty, + + structs = IM.insert (IM.empty, 0, []) +} + +fun pushDatatype (env : env) x n xncs = + {datatypes = IM.insert (#datatypes env, n, (x, xncs)), + constructors = foldl (fn ((x, n', to), constructors) => + IM.insert (constructors, n', (x, to, n))) + (#constructors env) xncs, + + numRelE = #numRelE env, + relE = #relE env, + namedE = #namedE env, + + structs = #structs env} + +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupConstructor (env : env) n = + case IM.find (#constructors env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushERel (env : env) x t = + {datatypes = #datatypes env, + constructors = #constructors env, + + numRelE = #numRelE env + 1, + relE = (x, t) :: #relE env, + namedE = #namedE env, + + structs = #structs env} + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun countERels (env : env) = #numRelE env + +fun listERels (env : env) = #relE env + +fun pushENamed (env : env) x n t = + {datatypes = #datatypes env, + constructors = #constructors env, + + numRelE = #numRelE env, + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t)), + + structs = #structs env} + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushStruct (env : env) n xts = + {datatypes = #datatypes env, + constructors = #constructors env, + + numRelE = #numRelE env, + relE = #relE env, + namedE = #namedE env, + + structs = IM.insert (#structs env, n, xts)} + +fun lookupStruct (env : env) n = + case IM.find (#structs env, n) of + NONE => raise UnboundStruct n + | SOME x => x + +fun classifyDatatype xncs = + if List.all (fn (_, _, NONE) => true | _ => false) xncs then + Enum + else + Default + +fun declBinds env (d, loc) = + case d of + DDatatype dts => + foldl (fn ((_, x, n, xncs), env) => + let + val env = pushDatatype env x n xncs + val dt = (TDatatype (classifyDatatype xncs, n, ref xncs), loc) + in + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc)) + env xncs + end) env dts + | DDatatypeForward (_, x, n) => pushDatatype env x n [] + | DStruct (n, xts) => pushStruct env n xts + | DVal (x, n, t, _) => pushENamed env x n t + | DFun (fx, n, args, ran, _) => + let + val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args + in + pushENamed env fx n t + end + | DFunRec vis => + foldl (fn ((fx, n, args, ran, _), env) => + let + val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args + in + pushENamed env fx n t + end) env vis + | DTable _ => env + | DSequence _ => env + | DView _ => env + | DDatabase _ => env + | DPreparedStatements _ => env + | DJavaScript _ => env + | DCookie _ => env + | DStyle _ => env + | DTask _ => env + | DOnError _ => env + +end diff --git a/src/cjr_print.sig b/src/cjr_print.sig new file mode 100644 index 0000000..baef005 --- /dev/null +++ b/src/cjr_print.sig @@ -0,0 +1,39 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web C jr. language *) + +signature CJR_PRINT = sig + val p_typ : CjrEnv.env -> Cjr.typ Print.printer + val p_exp : CjrEnv.env -> Cjr.exp Print.printer + val p_decl : CjrEnv.env -> Cjr.decl Print.printer + val p_file : CjrEnv.env -> Cjr.file Print.printer + + val p_sql : CjrEnv.env -> Cjr.file Print.printer + + val debug : bool ref +end diff --git a/src/cjr_print.sml b/src/cjr_print.sml new file mode 100644 index 0000000..53587ff --- /dev/null +++ b/src/cjr_print.sml @@ -0,0 +1,3749 @@ +(* Copyright (c) 2008-2014, 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. + *) + +(* Pretty-printing C jr. *) + +structure CjrPrint :> CJR_PRINT = struct + +open Print.PD +open Print + +open Cjr + +val dummyt = (TRecord 0, ErrorMsg.dummySpan) + +structure E = CjrEnv +structure EM = ErrorMsg + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure IS = IntBinarySet + +structure CM = BinaryMapFn(struct + type ord_key = char + val compare = Char.compare + end) + +val debug = ref false + +val app_js = ref "" + +val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) + +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +val p_ident = string o ident + +fun isUnboxable (t : typ) = + case #1 t of + TDatatype (Default, _, _) => true + | TFfi ("Basis", "string") => true + | TFfi ("Basis", "queryString") => true + | _ => false + +fun p_typ' par env (t, loc) = + case t of + TFun (t1, t2) => (EM.errorAt loc "Function type remains"; + string "<FUNCTION>") + | TRecord 0 => string "uw_unit" + | TRecord i => box [string "struct", + space, + string "__uws_", + string (Int.toString i)] + | TDatatype (Enum, n, _) => + (box [string "enum", + space, + string ("__uwe_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n)] + handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) + | TDatatype (Option, n, xncs) => + (case ListUtil.search #3 (!xncs) of + NONE => raise Fail "CjrPrint: TDatatype marked Option has no constructor with an argument" + | SOME t => + if isUnboxable t then + p_typ' par env t + else + box [p_typ' par env t, + string "*"]) + | TDatatype (Default, n, _) => + (box [string "struct", + space, + string ("__uwd_" ^ ident (#1 (E.lookupDatatype env n)) ^ "_" ^ Int.toString n ^ "*")] + handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) + | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] + | TOption t => + if isUnboxable t then + p_typ' par env t + else + box [p_typ' par env t, + string "*"] + | TList (_, i) => box [string "struct", + space, + string "__uws_", + string (Int.toString i), + string "*"] + +and p_typ env = p_typ' false env + +fun p_htyp' par env (t, loc) = + case t of + TFun (t1, t2) => parenIf par (box [p_htyp' true env t1, + space, + string "->", + space, + p_htyp' true env t2]) + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "{", + p_list (fn (x, t) => + box [string x, + space, + string ":", + space, + p_htyp env t]) xts, + string "}"] + end + | TDatatype (_, n, _) => + let + val (name, _) = E.lookupDatatype env n + in + string name + end + | TFfi (m, x) => string (m ^ "." ^ x) + | TOption t => parenIf par (box [string "option", + space, + p_htyp' true env t]) + | TList (t, _) => parenIf par (box [string "list", + space, + p_htyp' true env t]) + +and p_htyp env = p_htyp' false env + +fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1)) + handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1)) + +fun p_enamed' env n = + "__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n + handle CjrEnv.UnboundNamed _ => "__uwn_UNBOUND_" ^ Int.toString n + +fun p_enamed env n = string (p_enamed' env n) + +fun p_con_named env n = + string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n) + handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n) + +fun p_pat_preamble env (p, _) = + case p of + PVar (x, t) => (box [p_typ env t, + space, + string "__uwr_", + p_ident x, + string "_", + string (Int.toString (E.countERels env)), + string ";", + newline], + E.pushERel env x t) + | PPrim _ => (box [], env) + | PCon (_, _, NONE) => (box [], env) + | PCon (_, _, SOME p) => p_pat_preamble env p + | PRecord xps => + foldl (fn ((_, p, _), (pp, env)) => + let + val (pp', env) = p_pat_preamble env p + in + (box [pp', pp], env) + end) (box [], env) xps + | PNone _ => (box [], env) + | PSome (_, p) => p_pat_preamble env p + +fun p_patCon env pc = + case pc of + PConVar n => p_con_named env n + | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con) + +fun p_patMatch (env, disc) (p, loc) = + case p of + PVar _ => string "1" + | PPrim (Prim.Int n) => box [string ("(" ^ disc), + space, + string "==", + space, + Prim.p_t_GCC (Prim.Int n), + string ")"] + | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc), + string ",", + space, + Prim.p_t_GCC (Prim.String s), + string ")"] + | PPrim (Prim.Char ch) => box [string ("(" ^ disc), + space, + string "==", + space, + Prim.p_t_GCC (Prim.Char ch), + string ")"] + | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" + + | PCon (dk, pc, po) => + let + val p = + case po of + NONE => box [] + | SOME p => + let + val (x, to) = case pc of + PConVar n => + let + val (x, to, _) = E.lookupConstructor env n + in + ("uw_" ^ ident x, to) + end + | PConFfi {mod = m, con, arg, ...} => + ("uw_" ^ ident m ^ "_" ^ ident con, arg) + + val t = case to of + NONE => raise Fail "CjrPrint: Constructor mismatch" + | SOME t => t + + val x = case pc of + PConVar n => + let + val (x, _, _) = E.lookupConstructor env n + in + "uw_" ^ ident x + end + | PConFfi {mod = m, con, ...} => + "uw_" ^ ident m ^ "_" ^ ident con + + val disc' = case dk of + Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" + | Default => disc ^ "->data." ^ x + | Option => + if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + + val p = p_patMatch (env, disc') p + in + box [space, + string "&&", + space, + p] + end + in + box [string disc, + case (dk, po) of + (Enum, _) => box [space, + string "==", + space, + p_patCon env pc] + | (Default, _) => box [string "->tag", + space, + string "==", + space, + p_patCon env pc] + | (Option, NONE) => box [space, + string "==", + space, + string "NULL"] + | (Option, SOME _) => box [space, + string "!=", + space, + string "NULL"], + p] + end + + | PRecord [] => string "1" + | PRecord xps => + p_list_sep (box [space, string "&&", space]) (fn (x, p, _) => p_patMatch (env, disc ^ ".__uwf_" ^ ident x) p) xps + + | PNone _ => + box [string disc, + space, + string "==", + space, + string "NULL"] + + | PSome (t, p) => + let + val disc' = if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + + val p = p_patMatch (env, disc') p + in + box [string disc, + space, + string "!=", + space, + string "NULL", + space, + string "&&", + space, + p] + end + +fun p_patBind (env, disc) (p, loc) = + case p of + PVar (x, t) => + (box [p_typ env t, + space, + string "__uwr_", + p_ident x, + string "_", + string (Int.toString (E.countERels env)), + space, + string "=", + space, + string disc, + string ";", + newline], + E.pushERel env x t) + | PPrim _ => (box [], env) + + | PCon (_, _, NONE) => (box [], env) + + | PCon (dk, pc, SOME p) => + let + val (x, to) = case pc of + PConVar n => + let + val (x, to, _) = E.lookupConstructor env n + in + ("uw_" ^ ident x, to) + end + | PConFfi {mod = m, con, arg, ...} => + ("uw_" ^ ident m ^ "_" ^ ident con, arg) + + val t = case to of + NONE => raise Fail "CjrPrint: Constructor mismatch" + | SOME t => t + + val disc' = case dk of + Enum => raise Fail "CjrPrint: Looking at argument of no-argument constructor" + | Default => disc ^ "->data." ^ x + | Option => + if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + in + p_patBind (env, disc') p + end + + | PRecord xps => + let + val (xps, env) = + ListUtil.foldlMap (fn ((x, p, t), env) => p_patBind (env, disc ^ ".__uwf_" ^ ident x) p) + env xps + in + (p_list_sep (box []) (fn x => x) xps, + env) + end + + | PNone _ => (box [], env) + + | PSome (t, p) => + let + val disc' = if isUnboxable t then + disc + else + "(*" ^ disc ^ ")" + in + p_patBind (env, disc') p + end + +fun patConInfo env pc = + case pc of + PConVar n => + let + val (x, _, dn) = E.lookupConstructor env n + val (dx, _) = E.lookupDatatype env dn + in + ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn, + "__uwc_" ^ ident x ^ "_" ^ Int.toString n, + "uw_" ^ ident x) + end + | PConFfi {mod = m, datatyp, con, ...} => + ("uw_" ^ ident m ^ "_" ^ ident datatyp, + "uw_" ^ ident m ^ "_" ^ ident con, + "uw_" ^ ident con) + +fun p_unsql wontLeakStrings env (tAll as (t, loc)) e eLen = + case t of + TFfi ("Basis", "int") => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] + | TFfi ("Basis", "float") => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] + | TFfi ("Basis", "string") => + if wontLeakStrings then + e + else + box [string "uw_strdup(ctx, ", e, string ")"] + | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] + | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"] + | TFfi ("Basis", "blob") => box [string "uw_Basis_stringToBlob_error(ctx, ", + e, + string ", ", + eLen, + string ")"] + | TFfi ("Basis", "channel") => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] + | TFfi ("Basis", "client") => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] + + | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; + Print.eprefaces' [("Type", p_htyp env tAll)]; + string "ERROR") + +fun p_getcol wontLeakStrings env (tAll as (t, loc)) i = + case t of + TOption t => + box [string "(PQgetisnull(res, i, ", + string (Int.toString i), + string ") ? NULL : ", + case t of + (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i + | _ => box [string "({", + newline, + p_typ env t, + space, + string "*tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + p_getcol wontLeakStrings env t i, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + | _ => + box [string "(PQgetisnull(res, i, ", + string (Int.toString i), + string ") ? ", + box [string "({", + p_typ env tAll, + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #", + string (Int.toString i), + string "\");", + newline, + string "tmp;", + newline, + string "})"], + string " : ", + p_unsql wontLeakStrings env tAll + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + (box [string "PQgetlength(res, i, ", + string (Int.toString i), + string ")"]), + string ")"] + +datatype sql_type = datatype Settings.sql_type +val isBlob = Settings.isBlob + +fun isFile (t : typ) = + case #1 t of + TFfi ("Basis", "file") => true + | _ => false + +fun p_sql_type t = string (Settings.p_sql_ctype t) + +fun getPargs (e, _) = + case e of + EPrim (Prim.String _) => [] + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2 + + | EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)] + | EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)] + | EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)] + | EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)] + | EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)] + | EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)] + | EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)] + | EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)] + + | ECase (e, + [((PNone _, _), + (EPrim (Prim.String (_, "NULL")), _)), + ((PSome (_, (PVar _, _)), _), + (EFfiApp (m, x, [((ERel 0, _), _)]), _))], + {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e)) + + | ECase (e, + [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), + (EPrim (Prim.String (_, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), + (EPrim (Prim.String (_, "FALSE")), _))], + _) => [(e, Bool)] + + | _ => raise Fail "CjrPrint: getPargs" + +val notLeakies = SS.fromList ["int", "float", "char", "time", "bool", "unit", "client", "channel", + "xhtml", "page", "xbody", "css_class"] +val notLeakies' = SS.fromList ["blob"] + +fun notLeaky env allowHeapAllocated = + let + fun nl ok (t, _) = + case t of + TFun _ => false + | TRecord n => + let + val xts = E.lookupStruct env n + in + List.all (fn (_, t) => nl ok t) xts + end + | TDatatype (dk, n, ref cons) => + IS.member (ok, n) + orelse + ((allowHeapAllocated orelse dk = Enum) + andalso + let + val ok' = IS.add (ok, n) + in + List.all (fn (_, _, to) => case to of + NONE => true + | SOME t => nl ok' t) cons + end) + | TFfi ("Basis", t) => SS.member (notLeakies, t) + orelse (allowHeapAllocated andalso SS.member (notLeakies', t)) + | TFfi _ => false + | TOption t => allowHeapAllocated andalso nl ok t + | TList (t, _) => allowHeapAllocated andalso nl ok t + in + nl IS.empty + end + +fun capitalize s = + if s = "" then + "" + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +local + val urlHandlers = ref ([] : (pp_desc * pp_desc) list) +in + +fun addUrlHandler v = urlHandlers := v :: !urlHandlers + +fun latestUrlHandlers () = + !urlHandlers + before urlHandlers := [] + +fun clearUrlHandlers () = urlHandlers := [] + +end + +val unurlifies = ref IS.empty + +fun unurlify fromClient env (t, loc) = + let + fun deStar request = + case request of + "(*request)" => "request" + | _ => "&" ^ request + + fun unurlify' request t = + case t of + TFfi ("Basis", "unit") => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")") + | TFfi ("Basis", "string") => string (if fromClient then + "uw_Basis_unurlifyString_fromClient(ctx, " ^ deStar request ^ ")" + else + "uw_Basis_unurlifyString(ctx, " ^ deStar request ^ ")") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, " ^ deStar request ^ ")") + + | TRecord 0 => string ("uw_Basis_unurlifyUnit(ctx, " ^ deStar request ^ ")") + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "({", + newline, + box (map (fn (x, t) => + box [p_typ env t, + space, + string "uwr_", + string x, + space, + string "=", + space, + unurlify' request (#1 t), + string ";", + newline]) xts), + string "struct", + space, + string "__uws_", + string (Int.toString i), + space, + string "tmp", + space, + string "=", + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", + string x]) xts, + space, + string "};", + newline, + string "tmp;", + newline, + string "})"] + end + + | TDatatype (Enum, i, _) => + let + val (x, xncs) = E.lookupDatatype env i + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), (enum __uwe_" + ^ x ^ "_" ^ Int.toString i ^ ")0)") + | (x', n, to) :: rest => + box [string ("((!strncmp(" ^ request ^ ", \""), + string x', + string "\", ", + string (Int.toString (size x')), + string (") && (" ^ request ^ "["), + string (Int.toString (size x')), + string ("] == 0 || " ^ request ^ "["), + string (Int.toString (size x')), + string ("] == '/')) ? (" ^ request ^ " += "), + string (Int.toString (size x')), + string (", (" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"), + space, + string ":", + space, + doEm rest, + string ")"] + in + doEm xncs + end + + | TDatatype (Option, i, xncs) => + if IS.member (!unurlifies, i) then + box [string "unurlify_", + string (Int.toString i), + string ("(ctx, " ^ deStar request ^ ")")] + else + let + val (x, _) = E.lookupDatatype env i + + val (no_arg, has_arg, t) = + case !xncs of + [(no_arg, _, NONE), (has_arg, _, SOME t)] => + (no_arg, has_arg, t) + | [(has_arg, _, SOME t), (no_arg, _, NONE)] => + (no_arg, has_arg, t) + | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype" + + val unboxable = isUnboxable t + in + unurlifies := IS.add (!unurlifies, i); + addUrlHandler (box [string "static", + space, + p_typ env t, + space, + if unboxable then + box [] + else + string "*", + string "unurlify_", + string (Int.toString i), + string "(uw_context, char **);", + newline], + box [string "static", + space, + p_typ env t, + space, + if unboxable then + box [] + else + string "*", + string "unurlify_", + string (Int.toString i), + string "(uw_context ctx, char **request) {", + newline, + box [string "return ((*request)[0] == '/' ? ++*request : *request,", + newline, + string "((!strncmp(*request, \"", + string no_arg, + string "\", ", + string (Int.toString (size no_arg)), + string ") && ((*request)[", + string (Int.toString (size no_arg)), + string "] == 0 || (*request)[", + string (Int.toString (size no_arg)), + string "] == '/')) ? (*request", + space, + string "+=", + space, + string (Int.toString (size no_arg)), + string ", NULL) : ((!strncmp(*request, \"", + string has_arg, + string "\", ", + string (Int.toString (size has_arg)), + string ") && ((*request)[", + string (Int.toString (size has_arg)), + string "] == 0 || (*request)[", + string (Int.toString (size has_arg)), + string "] == '/')) ? (*request", + space, + string "+=", + space, + string (Int.toString (size has_arg)), + string ", ((*request)[0] == '/' ? ++*request : NULL), ", + newline, + + if unboxable then + unurlify' "(*request)" (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' "(*request)" (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")", + newline, + string ":", + space, + string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x + ^ "\"), NULL))));"), + newline], + string "}", + newline, + newline]); + + box [string "unurlify_", + string (Int.toString i), + string ("(ctx, &" ^ request ^ ")")] + end + + | TDatatype (Default, i, _) => + if IS.member (!unurlifies, i) then + box [string "unurlify_", + string (Int.toString i), + string ("(ctx, " ^ deStar request ^ ")")] + else + let + val (x, xncs) = E.lookupDatatype env i + + val () = unurlifies := IS.add (!unurlifies, i) + + fun doEm xncs = + case xncs of + [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " + ^ x ^ "\"), NULL)") + | (x', n, to) :: rest => + box [string "((!strncmp(*request, \"", + string x', + string "\", ", + string (Int.toString (size x')), + string ") && ((*request)[", + string (Int.toString (size x')), + string "] == 0 || (*request)[", + string (Int.toString (size x')), + string "] == '/')) ? ({", + newline, + string "struct", + space, + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), + space, + string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", + string x, + string "_", + string (Int.toString i), + string "));", + newline, + string "tmp->tag", + space, + string "=", + space, + string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), + string ";", + newline, + string "*request", + space, + string "+=", + space, + string (Int.toString (size x')), + string ";", + newline, + string "if ((*request)[0] == '/') ++*request;", + newline, + case to of + NONE => box [] + | SOME (t, _) => box [string "tmp->data.uw_", + p_ident x', + space, + string "=", + space, + unurlify' "(*request)" t, + string ";", + newline], + string "tmp;", + newline, + string "})", + space, + string ":", + space, + doEm rest, + string ")"] + in + addUrlHandler (box [string "static", + space, + p_typ env (t, ErrorMsg.dummySpan), + space, + string "unurlify_", + string (Int.toString i), + string "(uw_context, char **);", + newline], + box [string "static", + space, + p_typ env (t, ErrorMsg.dummySpan), + space, + string "unurlify_", + string (Int.toString i), + string "(uw_context ctx, char **request) {", + newline, + box [string "return", + space, + doEm xncs, + string ";", + newline], + string "}", + newline, + newline]); + + box [string "unurlify_", + string (Int.toString i), + string ("(ctx, " ^ deStar request ^ ")")] + end + + | TList (t', i) => + if IS.member (!unurlifies, i) then + box [string "unurlify_list_", + string (Int.toString i), + string ("(ctx, " ^ deStar request ^ ")")] + else + (unurlifies := IS.add (!unurlifies, i); + addUrlHandler (box [string "static", + space, + p_typ env (t, loc), + space, + string "unurlify_list_", + string (Int.toString i), + string "(uw_context, char **);", + newline], + box [string "static", + space, + p_typ env (t, loc), + space, + string "unurlify_list_", + string (Int.toString i), + string "(uw_context ctx, char **request) {", + newline, + box [string "return ((*request)[0] == '/' ? ++*request : *request,", + newline, + string "((!strncmp(*request, \"Nil\", 3) && ((*request)[3] == 0 ", + string "|| (*request)[3] == '/')) ? (*request", + space, + string "+=", + space, + string "3, ((*request)[0] == '/' ? ((*request)[0] = 0, ++*request) : NULL), NULL) : ((!strncmp(*request, \"Cons\", 4) && ((*request)[4] == 0 ", + string "|| (*request)[4] == '/')) ? (*request", + space, + string "+=", + space, + string "4, ((*request)[0] == '/' ? ++*request : NULL), ", + newline, + + string "({", + newline, + p_typ env (t, loc), + space, + string "tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(struct __uws_", + string (Int.toString i), + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' "(*request)" (TRecord i), + string ";", + newline, + string "tmp;", + newline, + string "})", + string ")", + newline, + string ":", + space, + string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"), + newline], + string "}", + newline, + newline]); + + box [string "unurlify_list_", + string (Int.toString i), + string ("(ctx, " ^ deStar request ^ ")")]) + + | TOption t => + box [string ("(" ^ request ^ "[0] == '/' ? ++" ^ request ^ " : " ^ request ^ ", "), + string ("((!strncmp(" ^ request ^ ", \"None\", 4) "), + string ("&& (" ^ request ^ "[4] == 0 || " ^ request ^ "[4] == '/')) "), + string ("? (" ^ request ^ " += (" ^ request ^ "[4] == 0 ? 4 : 5), NULL) "), + string (": ((!strncmp(" ^ request ^ ", \"Some\", 4) "), + string ("&& " ^ request ^ "[4] == '/') "), + string ("? (" ^ request ^ " += 5, "), + if isUnboxable t then + unurlify' request (#1 t) + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + unurlify' request (#1 t), + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ") :", + space, + string "(uw_error(ctx, FATAL, \"Error unurlifying option type\"), NULL))))"] + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; + space) + in + unurlify' "request" t + end + +val urlify1 = ref 0 + +val urlifies = ref IS.empty +val urlifiesL = ref IS.empty + +fun urlify env t = + let + fun urlify' level (t as (_, loc)) = + case #1 t of + TFfi ("Basis", "unit") => box [] + | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t + ^ "_w(ctx, it" ^ Int.toString level ^ ");"), + newline] + + | TRecord 0 => box [] + | 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) + ([], false) xts + in + box (rev blocks) + end + + | TDatatype (Enum, i, _) => + let + val (x, xncs) = E.lookupDatatype env i + + fun doEm xncs = + case xncs of + [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " + ^ x ^ "\");"), + newline] + | (x', n, to) :: rest => + box [string ("if (it" ^ Int.toString level + ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"), + newline, + box [string ("uw_write(ctx, \"" ^ x' ^ "\");"), + newline], + string "} else {", + newline, + box [doEm rest, + newline], + string "}"] + in + doEm xncs + end + + | TDatatype (Option, i, xncs) => + if IS.member (!urlifies, i) then + box [string "urlify_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline] + else + let + val (x, _) = E.lookupDatatype env i + + val (no_arg, has_arg, t) = + case !xncs of + [(no_arg, _, NONE), (has_arg, _, SOME t)] => + (no_arg, has_arg, t) + | [(has_arg, _, SOME t), (no_arg, _, NONE)] => + (no_arg, has_arg, t) + | _ => raise Fail "CjrPrint: urlify misclassified Option datatype" + in + urlifies := IS.add (!urlifies, i); + addUrlHandler (box [string "static", + space, + string "void", + space, + string "urlify_", + string (Int.toString i), + string "(uw_context,", + space, + p_typ env t, + space, + if isUnboxable t then + box [] + else + string "*", + string ");", + newline], + box [string "static", + space, + string "void", + space, + string "urlify_", + string (Int.toString i), + string "(uw_context ctx,", + space, + p_typ env t, + space, + if isUnboxable t then + box [] + else + string "*", + string "it0) {", + newline, + box [string "if (it0) {", + newline, + if isUnboxable t then + box [string "uw_write(ctx, \"", + string has_arg, + string "/\");", + newline, + urlify' 0 t, + string ";", + newline] + else + box [p_typ env t, + space, + string "it1", + space, + string "=", + space, + string "*it0;", + newline, + string "uw_write(ctx, \"", + string has_arg, + string "/\");", + newline, + urlify' 1 t, + string ";", + newline], + string "} else {", + box [newline, + string "uw_write(ctx, \"", + string no_arg, + string "\");", + newline], + string "}", + newline], + string "}", + newline, + newline]); + + box [string "urlify_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline] + end + + | TDatatype (Default, i, _) => + if IS.member (!urlifies, i) then + box [string "urlify_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline] + else + let + val (x, xncs) = E.lookupDatatype env i + + val () = urlifies := IS.add (!urlifies, i) + + fun doEm xncs = + case xncs of + [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " + ^ x ^ " (%d)\", it0->data);"), + newline] + | (x', n, to) :: rest => + box [string "if", + space, + string "(it0->tag==__uwc_", + string (ident x'), + string "_", + string (Int.toString n), + string ") {", + newline, + case to of + NONE => box [string "uw_write(ctx, \"", + string x', + string "\");", + newline] + | SOME t => box [string "uw_write(ctx, \"", + string x', + string "/\");", + newline, + p_typ env t, + space, + string "it1", + space, + string "=", + space, + string "it0->data.uw_", + string x', + string ";", + newline, + urlify' 1 t, + newline], + string "} else {", + newline, + box [doEm rest, + newline], + string "}", + newline] + in + addUrlHandler (box [string "static", + space, + string "void", + space, + string "urlify_", + string (Int.toString i), + string "(uw_context,", + space, + p_typ env t, + string ");", + newline], + box [string "static", + space, + string "void", + space, + string "urlify_", + string (Int.toString i), + string "(uw_context ctx,", + space, + p_typ env t, + space, + string "it0) {", + newline, + box [doEm xncs, + newline], + newline, + string "}", + newline, + newline]); + + box [string "urlify_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline] + end + + | TOption t => + box [string "if (it", + string (Int.toString level), + string ") {", + if isUnboxable t then + box [string "uw_write(ctx, \"Some/\");", + newline, + urlify' level t] + else + box [p_typ env t, + space, + string "it", + string (Int.toString (level + 1)), + space, + string "=", + space, + string "*it", + string (Int.toString level), + string ";", + newline, + string "uw_write(ctx, \"Some/\");", + newline, + urlify' (level + 1) t, + string ";", + newline], + string "} else {", + box [newline, + string "uw_write(ctx, \"None\");", + newline], + string "}", + newline] + + | TList (t, i) => + if IS.member (!urlifiesL, i) then + box [string "urlifyl_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline] + else + (urlifiesL := IS.add (!urlifiesL, i); + addUrlHandler (box [string "static", + space, + string "void", + space, + string "urlifyl_", + string (Int.toString i), + string "(uw_context,", + space, + string "struct __uws_", + string (Int.toString i), + space, + string "*);", + newline], + box [string "static", + space, + string "void", + space, + string "urlifyl_", + string (Int.toString i), + string "(uw_context ctx,", + space, + string "struct __uws_", + string (Int.toString i), + space, + string "*it0) {", + newline, + box [string "if (it0) {", + newline, + p_typ env t, + space, + string "it1", + space, + string "=", + space, + string "it0->__uwf_1;", + newline, + string "uw_write(ctx, \"Cons/\");", + newline, + urlify' 1 t, + string ";", + newline, + string "uw_write(ctx, \"/\");", + newline, + string "urlifyl_", + string (Int.toString i), + string "(ctx, it0->__uwf_2);", + newline, + string "} else {", + newline, + box [string "uw_write(ctx, \"Nil\");", + newline], + string "}", + newline], + string "}", + newline, + newline]); + + box [string "urlifyl_", + string (Int.toString i), + string "(ctx,", + space, + string "it", + string (Int.toString level), + string ");", + newline]) + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; + space) + in + urlify' 0 t + end + +fun sql_type_in env (tAll as (t, loc)) = + case t of + TFfi ("Basis", "int") => Int + | TFfi ("Basis", "float") => Float + | TFfi ("Basis", "string") => String + | TFfi ("Basis", "char") => Char + | TFfi ("Basis", "bool") => Bool + | TFfi ("Basis", "time") => Time + | TFfi ("Basis", "blob") => Blob + | TFfi ("Basis", "channel") => Channel + | TFfi ("Basis", "client") => Client + | TOption t' => Nullable (sql_type_in env t') + | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; + Print.eprefaces' [("Type", p_htyp env tAll)]; + Int) + +fun potentiallyFancy (e, _) = + case e of + EPrim _ => false + | ERel _ => false + | ENamed _ => false + | ECon (_, _, NONE) => false + | ECon (_, _, SOME e) => potentiallyFancy e + | ENone _ => false + | ESome (_, e) => potentiallyFancy e + | EFfi _ => false + | EFfiApp _ => true + | EApp _ => true + | EUnop (_, e) => potentiallyFancy e + | EBinop (_, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 + | ERecord (_, xes) => List.exists (potentiallyFancy o #2) xes + | EField (e, _) => potentiallyFancy e + | ECase (e, pes, _) => potentiallyFancy e orelse List.exists (potentiallyFancy o #2) pes + | EError _ => false + | EReturnBlob _ => false + | ERedirect _ => false + | EWrite e => potentiallyFancy e + | ESeq (e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 + | ELet (_, _, e1, e2) => potentiallyFancy e1 orelse potentiallyFancy e2 + | EQuery _ => true + | EDml {dml = e, ...} => potentiallyFancy e + | ENextval {seq = e, ...} => potentiallyFancy e + | ESetval {seq = e1, count = e2} => potentiallyFancy e1 orelse potentiallyFancy e2 + | EUnurlify _ => true + +val self = ref (NONE : int option) + +(* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation. + * Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *) +fun pFuncall env (m, x, es, extra) = + case es of + [] => box [string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx", + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ")"] + | [(e, _)] => box [string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx,", + space, + p_exp' false false env e, + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ")"] + | _ => box [string "({", + newline, + p_list_sepi (box []) (fn i => fn (e, t) => + box [p_typ env t, + space, + string "arg", + string (Int.toString i), + space, + string "=", + space, + p_exp' false false env e, + string ";", + newline]) es, + string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx, ", + p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es, + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ");", + newline, + string "})"] + +and p_exp' par tail env (e, loc) = + case e of + EPrim p => Prim.p_t_GCC p + | ERel n => p_rel env n + | ENamed n => p_enamed env n + | ECon (Enum, pc, _) => p_patCon env pc + | ECon (Option, pc, NONE) => string "NULL" + | ECon (Option, pc, SOME e) => + let + val to = case pc of + PConVar n => #2 (E.lookupConstructor env n) + | PConFfi {arg, ...} => arg + + val t = case to of + NONE => raise Fail "CjrPrint: ECon argument status mismatch" + | SOME t => t + in + if isUnboxable t then + p_exp' par tail env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + p_exp' par false env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] + end + | ECon (Default, pc, eo) => + let + val (xd, xc, xn) = patConInfo env pc + in + box [string "({", + newline, + string "struct", + space, + string xd, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(struct ", + string xd, + string "));", + newline, + string "tmp->tag", + space, + string "=", + space, + string xc, + string ";", + newline, + case eo of + NONE => box [] + | SOME e => box [string "tmp->data.", + string xn, + space, + string "=", + space, + p_exp' false false env e, + string ";", + newline], + string "tmp;", + newline, + string "})"] + end + | ENone _ => string "NULL" + | ESome (t, e) => + if isUnboxable t then + p_exp' par tail env e + else + box [string "({", + newline, + p_typ env t, + space, + string "*tmp", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp", + space, + string "=", + space, + p_exp' par false env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] + + | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] + | EError (e, t) => + box [string "({", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"", + string (if Settings.getDebug () then + ErrorMsg.spanToString loc ^ ": " + else + ""), + string "%s\", ", + p_exp' false false env e, + string ");", + newline, + string "tmp;", + newline, + string "})"] + | EReturnBlob {blob = SOME blob, mimeType, t} => + box [string "({", + newline, + string "uw_Basis_blob", + space, + string "blob", + space, + string "=", + space, + p_exp' false false env blob, + string ";", + newline, + string "uw_Basis_string", + space, + string "mimeType", + space, + string "=", + space, + p_exp' false false env mimeType, + string ";", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_return_blob(ctx, blob, mimeType);", + newline, + string "tmp;", + newline, + string "})"] + | EReturnBlob {blob = NONE, mimeType, t} => + box [string "({", + newline, + string "uw_Basis_string", + space, + string "mimeType", + space, + string "=", + space, + p_exp' false false env mimeType, + string ";", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_return_blob_from_page(ctx, mimeType);", + newline, + string "tmp;", + newline, + string "})"] + | ERedirect (e, t) => + box [string "({", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_redirect(ctx, ", + p_exp' false false env e, + string ");", + newline, + string "tmp;", + newline, + string "})"] + | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => + p_exp' false false env (EError (e, ran), loc) + | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => + p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc) + + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => + let + fun flatten e = + case #1 e of + EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2 + | _ => [e] + + val es = flatten e1 @ flatten e2 + val t = (TFfi ("Basis", "string"), loc) + val es = map (fn e => (e, t)) es + in + case es of + [_, _] => pFuncall env ("Basis", "strcat", es, NONE) + | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL") + end + + | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE) + | EApp (f, args) => + let + fun getSig n = + let + val (_, t) = E.lookupENamed env n + + fun getSig (t, args) = + case #1 t of + TFun (dom, t) => getSig (t, dom :: args) + | _ => (args, t) + in + getSig (t, []) + end + + fun default () = + case (#1 f, args) of + (ENamed n, _ :: _ :: _) => + let + val (args', ret) = getSig n + val args = ListPair.zip (args, args') + in + parenIf par (box [string "({", + newline, + p_list_sepi newline + (fn i => fn (e, t) => + box [p_typ env t, + space, + string ("arg" ^ Int.toString i), + space, + string "=", + space, + p_exp' false false env e, + string ";"]) + args, + newline, + p_exp' false false env f, + string "(ctx,", + space, + p_list_sepi (box [string ",", space]) + (fn i => fn _ => + string ("arg" ^ Int.toString i)) args, + string ");", + newline, + string "})"]) + end + | _ => + parenIf par (box [p_exp' true false env f, + string "(ctx,", + space, + p_list_sep (box [string ",", space]) (p_exp' false false env) args, + string ")"]) + + fun isSelf n = + let + val (argts, ret) = getSig n + in + parenIf par (box [string "({", + newline, + p_list_sepi newline + (fn i => fn (e, t) => + box [p_typ env t, + space, + string ("rearg" ^ Int.toString i), + space, + string "=", + space, + p_exp' false false env e, + string ";"]) + (ListPair.zip (args, argts)), + newline, + p_typ env ret, + space, + string "tmp;", + newline, + p_list_sepi newline + (fn i => fn _ => + box [p_rel env (E.countERels env - 1 - i), + space, + string "=", + space, + string ("rearg" ^ Int.toString i ^ ";")]) args, + newline, + string "goto restart;", + newline, + string "tmp;", + newline, + string "})"]) + end + in + case #1 f of + ENamed n => if SOME n = !self andalso tail then + isSelf n + else + default () + | _ => default () + end + + | EUnop (s, e1) => + parenIf par (box [string s, + space, + p_exp' true false env e1]) + + | EBinop (s, e1, e2) => + if s <> "fdiv" andalso Char.isAlpha (String.sub (s, size s - 1)) then + box [string s, + string "(", + p_exp' false false env e1, + string ",", + space, + p_exp' false false env e2, + string ")"] + else if s = "/" orelse s = "%" then + box [string "({", + newline, + string "uw_Basis_int", + space, + string "dividend", + space, + string "=", + space, + p_exp env e1, + string ",", + space, + string "divisor", + space, + string "=", + space, + p_exp env e2, + string ";", + newline, + string "if", + space, + string "(divisor", + space, + string "==", + space, + string "0)", + newline, + box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": division by zero\");", + newline], + string "dividend", + space, + string s, + space, + string "divisor;", + newline, + string "})"] + else + parenIf par (box [p_exp' true false env e1, + space, + string (if s = "fdiv" then "/" else s), + space, + p_exp' true false env e2]) + + | ERecord (0, _) => string "0" + + | ERecord (i, xes) => box [string "({", + space, + string "struct", + space, + string ("__uws_" ^ Int.toString i), + space, + string "tmp", + space, + string "=", + space, + string "{", + p_list (fn (_, e) => + p_exp' false false env e) xes, + string "};", + space, + string "tmp;", + space, + string "})" ] + | EField (e, x) => + box [p_exp' true false env e, + string ".__uwf_", + p_ident x] + + | ECase (e, pes, {disc, result}) => + box [string "({", + newline, + p_typ env disc, + space, + string "disc", + space, + string "=", + space, + p_exp' false false env e, + string ";", + newline, + newline, + foldr (fn ((p, e), body) => + let + val pm = p_patMatch (env, "disc") p + val (pb, env') = p_patBind (env, "disc") p + in + box [pm, + space, + string "?", + space, + if E.countERels env' = E.countERels env then + p_exp' false tail env e + else + box [string "({", + pb, + p_exp' false tail env' e, + string ";", + newline, + string "})"], + newline, + space, + string ":", + space, + body] + end) (box [string "({", + newline, + p_typ env result, + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": pattern match failure\");", + newline, + string "tmp;", + newline, + string "})"]) pes, + string ";", + newline, + string "})"] + + | EWrite e => box [string "(uw_write(ctx, ", + p_exp' false false env e, + string "), 0)"] + + | ESeq (e1, e2) => + let + val useRegion = potentiallyFancy e1 + in + box [string "(", + if useRegion then + box [string "uw_begin_region(ctx),", + space] + else + box [], + p_exp' false false env e1, + string ",", + space, + if useRegion then + box [string "uw_end_region(ctx),", + space] + else + box [], + p_exp' false tail env e2, + string ")"] + end + | ELet (x, t, e1, e2) => + let + val useRegion = notLeaky env false t andalso potentiallyFancy e1 + in + box [string "({", + newline, + p_typ env t, + space, + string "__uwr_", + p_ident x, + string "_", + string (Int.toString (E.countERels env)), + space, + string "=", + space, + if useRegion then + box [string "(uw_begin_region(ctx),", + space] + else + box [], + p_exp' false false env e1, + if useRegion then + string ")" + else + box [], + string ";", + newline, + if useRegion then + box [string "uw_end_region(ctx);", + newline] + else + box [], + p_exp' false tail (E.pushERel env x t) e2, + string ";", + newline, + string "})"] + end + + | EQuery {exps, tables, rnum, state, query, body, initial, prepared} => + let + val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps + val tables = ListUtil.mapConcat (fn (x, xts) => + map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) + tables + + val sort = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) + val outputs = sort exps @ sort tables + + val wontLeakStrings = notLeaky env true state + val wontLeakAnything = notLeaky env false state + + val inputs = + case prepared of + NONE => [] + | SOME _ => getPargs query + + fun doCols p_getcol = + box [string "struct __uws_", + string (Int.toString rnum), + string " __uwr_r_", + string (Int.toString (E.countERels env)), + string ";", + newline, + p_typ env state, + space, + string "__uwr_acc_", + string (Int.toString (E.countERels env + 1)), + space, + string "=", + space, + string "acc;", + newline, + newline, + + if Settings.getDeadlines () then + box [string "uw_check_deadline(ctx);", + newline] + else + box [], + + p_list_sepi (box []) (fn i => + fn (proj, t) => + box [string "__uwr_r_", + string (Int.toString (E.countERels env)), + string ".", + string proj, + space, + string "=", + space, + p_getcol {loc = loc, + wontLeakStrings = wontLeakStrings, + col = i, + typ = sql_type_in env t}, + string ";", + newline]) outputs, + newline, + newline, + + string "acc", + space, + string "=", + space, + p_exp' false false (E.pushERel + (E.pushERel env "r" (TRecord rnum, loc)) + "acc" state) + body, + string ";", + newline] + in + box [if wontLeakAnything then + string "(uw_begin_region(ctx), " + else + box [], + string "({", + newline, + p_typ env state, + space, + string "acc", + space, + string "=", + space, + p_exp' false false env initial, + string ";", + newline, + string "int dummy = (uw_begin_region(ctx), 0);", + newline, + string "uw_ensure_transaction(ctx);", + newline, + + case prepared of + NONE => + box [string "char *query = ", + p_exp' false false env query, + string ";", + newline, + newline, + + #query (Settings.currentDbms ()) + {loc = loc, + cols = map (fn (_, t) => sql_type_in env t) outputs, + doCols = doCols}] + | SOME {id, query, nested} => + box [p_list_sepi newline + (fn i => fn (e, t) => + box [p_sql_type t, + space, + string "arg", + string (Int.toString (i + 1)), + space, + string "=", + space, + p_exp' false false env e, + string ";"]) + inputs, + newline, + newline, + + #queryPrepared (Settings.currentDbms ()) + {loc = loc, + id = id, + query = query, + inputs = map #2 inputs, + cols = map (fn (_, t) => sql_type_in env t) outputs, + doCols = doCols, + nested = nested}], + newline, + + if wontLeakAnything then + box [string "uw_end_region(ctx);", + newline] + else + box [], + string "acc;", + newline, + string "})", + if wontLeakAnything then + string ")" + else + box []] + end + + | EDml {dml, prepared, mode} => + box [string "(uw_begin_region(ctx), ({", + newline, + case prepared of + NONE => box [string "char *dml = ", + p_exp' false false env dml, + string ";", + newline, + string "uw_ensure_transaction(ctx);", + newline, + newline, + #dml (Settings.currentDbms ()) (loc, mode)] + | SOME {id, dml = dml'} => + let + val inputs = getPargs dml + in + box [p_list_sepi newline + (fn i => fn (e, t) => + box [p_sql_type t, + space, + string "arg", + string (Int.toString (i + 1)), + space, + string "=", + space, + p_exp' false false env e, + string ";"]) + inputs, + newline, + string "uw_ensure_transaction(ctx);", + newline, + newline, + + #dmlPrepared (Settings.currentDbms ()) {loc = loc, + id = id, + dml = dml', + inputs = map #2 inputs, + mode = mode}] + end, + newline, + newline, + string "uw_end_region(ctx);", + newline, + + case mode of + Settings.Error => string "0;" + | Settings.None => string "uw_dup_and_clear_error_message(ctx);", + + newline, + string "}))"] + + | ENextval {seq, prepared} => + box [string "({", + newline, + string "uw_Basis_int n;", + newline, + string "uw_ensure_transaction(ctx);", + newline, + + case prepared of + NONE => #nextval (Settings.currentDbms ()) {loc = loc, + seqE = p_exp' false false env seq, + seqName = case #1 seq of + EPrim (Prim.String (_, s)) => SOME s + | _ => NONE} + | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, + id = id, + query = query}, + newline, + newline, + + string "n;", + newline, + string "})"] + + | ESetval {seq, count} => + box [string "({", + newline, + string "uw_ensure_transaction(ctx);", + newline, + + #setval (Settings.currentDbms ()) {loc = loc, + seqE = p_exp' false false env seq, + count = p_exp' false false env count}, + newline, + newline, + + string "0;", + newline, + string "})"] + + | EUnurlify (e, t, true) => + let + fun getIt () = + if isUnboxable t then + unurlify false env t + else + box [string "({", + newline, + p_typ env t, + string " *tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + unurlify false env t, + string ";", + newline, + string "tmp;", + newline, + string "})"] + in + box [string "({", + newline, + string "uw_Basis_string request = uw_maybe_strdup(ctx, ", + p_exp' false false env e, + string ");", + newline, + newline, + string "(request ? ", + getIt (), + string " : NULL);", + newline, + string "})"] + end + + | EUnurlify (e, t, false) => + let + fun getIt () = + if isUnboxable t then + unurlify false env t + else + box [string "({", + newline, + p_typ env t, + string " *tmp = uw_malloc(ctx, sizeof(", + p_typ env t, + string "));", + newline, + string "*tmp = ", + unurlify false env t, + string ";", + newline, + string "tmp;", + newline, + string "})"] + in + box [string "({", + newline, + string "uw_Basis_string request = uw_maybe_strdup(ctx, ", + p_exp' false false env e, + string ");", + newline, + newline, + unurlify false env t, + string ";", + newline, + string "})"] + end + +and p_exp env = p_exp' false true env + +fun p_fun isRec env (fx, n, args, ran, e) = + let + val nargs = length args + val env' = foldl (fn ((x, dom), env) => E.pushERel env x dom) env args + in + box [string "static", + space, + p_typ env ran, + space, + string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), + string "(", + p_list_sep (box [string ",", space]) (fn x => x) + (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) => + box [p_typ env dom, + space, + p_rel env' (nargs - i - 1)]) args), + string ")", + space, + string "{", + if isRec then + box [string "restart:", + newline] + else + box [], + newline, + if isRec andalso Settings.getDeadlines () then + box [string "uw_check_deadline(ctx);", + newline] + else + box [], + box [string "return(", + p_exp env' e, + string ");"], + newline, + string "}"] + end + +val global_initializers : Print.PD.pp_desc list ref = ref [] + +fun p_decl env (dAll as (d, loc) : decl) = + case d of + DStruct (n, xts) => + let + val env = E.declBinds env dAll + in + box [string "struct", + space, + string ("__uws_" ^ Int.toString n), + space, + string "{", + newline, + p_list_sep (box []) (fn (x, t) => box [p_typ env t, + space, + string "__uwf_", + p_ident x, + string ";", + newline]) xts, + string "};"] + end + | DDatatype dts => + let + fun p_one (Enum, x, n, xncs) = + box [string "enum", + space, + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), + space, + string "{", + space, + case xncs of + [] => string ("__uwec_" ^ ident x ^ "_" ^ Int.toString n) + | _ => + p_list_sep (box [string ",", space]) (fn (x, n, _) => + string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs, + space, + string "};"] + | p_one (Option, _, _, _) = box [] + | p_one (Default, x, n, xncs) = + let + val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE + | (x, n, SOME t) => SOME (x, n, t)) xncs + in + box [string "enum", + space, + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, n, _) => + string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) + xncs, + space, + string "};", + newline, + newline, + string "struct", + space, + string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n), + space, + string "{", + newline, + string "enum", + space, + string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n), + space, + string "tag;", + newline, + box (case xncsArgs of + [] => [] + | _ => [string "union", + space, + string "{", + newline, + p_list_sep newline (fn (x, n, t) => box [p_typ env t, + space, + string ("uw_" ^ ident x), + string ";"]) xncsArgs, + newline, + string "}", + space, + string "data;", + newline]), + string "};"] + end + in + p_list_sep (box []) p_one dts + end + + | DDatatypeForward _ => box [] + + | DVal (x, n, t, e) => + (global_initializers := box [string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n), + space, + string "=", + space, + p_exp env e, + string ";"] :: !global_initializers; + box [p_typ env t, + space, + string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n ^ ";")]) + | DFun vi => p_fun false env vi + | DFunRec vis => + let + val env = E.declBinds env dAll + in + box [p_list_sep newline (fn (fx, n, args, ran, _) => + box [string "static", + space, + p_typ env ran, + space, + string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n), + string "(uw_context,", + space, + p_list_sep (box [string ",", space]) + (fn (_, dom) => p_typ env dom) args, + string ");"]) vis, + newline, + p_list_sep newline (fn vi as (_, n, _, _, _) => + (self := SOME n; + p_fun true env vi + before self := NONE)) vis, + newline] + end + | DTable (x, _, pk, csts) => box [string "/* SQL table ", + string x, + space, + case pk of + "" => box [] + | _ => box [string "keys", + space, + string pk, + space], + string "constraints", + space, + p_list (fn (x, v) => box [string x, + space, + string ":", + space, + string v]) csts, + space, + string " */", + newline] + | DSequence x => box [string "/* SQL sequence ", + string x, + string " */", + newline] + | DView (x, _, s) => box [string "/* SQL view ", + string x, + space, + string "AS", + space, + string s, + space, + string " */", + newline] + | DDatabase _ => box [] + | DPreparedStatements _ => box [] + + | DJavaScript s => + let + val name = + (case Settings.getOutputJsFile () of + NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js" + | SOME s => s) + val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), + file = name} + in + box [string "static char jslib[] = \"", + string (Prim.toCString s), + string "\";"] + end + | DCookie s => box [string "/*", + space, + string "cookie", + space, + string s, + space, + string "*/"] + | DStyle s => box [string "/*", + space, + string "style", + space, + string s, + space, + string "*/"] + + | DTask _ => box [] + | DOnError _ => box [] + +datatype 'a search = + Found of 'a + | NotFound + | Error + +fun p_sqltype'' env (tAll as (t, loc)) = + case t of + TFfi ("Basis", "int") => "int8" + | TFfi ("Basis", "float") => "float8" + | TFfi ("Basis", "string") => "text" + | TFfi ("Basis", "bool") => "bool" + | TFfi ("Basis", "time") => "timestamp" + | TFfi ("Basis", "blob") => "bytea" + | TFfi ("Basis", "channel") => "int8" + | TFfi ("Basis", "client") => "int4" + | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; + Print.eprefaces' [("Type", p_htyp env tAll)]; + "ERROR") + +fun p_sqltype' env (tAll as (t, loc)) = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t ^ " NOT NULL" + +fun p_sqltype env t = string (p_sqltype' env t) + +fun p_sqltype_base' env t = + case t of + (TOption t, _) => p_sqltype'' env t + | _ => p_sqltype'' env t + +fun p_sqltype_base env t = string (p_sqltype_base' env t) + +fun is_not_null t = + case t of + (TOption _, _) => false + | _ => true + +fun sigName fields = + let + fun inFields s = List.exists (fn (s', _) => s' = s) fields + + fun getSigName n = + let + val s = "Sig" ^ Int.toString n + in + if inFields s then + getSigName (n + 1) + else + s + end + in + if inFields "Sig" then + getSigName 0 + else + "Sig" + end + +fun p_file env (ds, ps) = + let + val () = (clearUrlHandlers (); + unurlifies := IS.empty; + urlifies := IS.empty; + urlifiesL := IS.empty; + self := NONE; + global_initializers := []) + + (* First, pull out all of the enumerated types, to be declared first. *) + val (ds, enums) = ListUtil.foldlMapPartial (fn (d, enums) => + case #1 d of + DDatatype dts => + let + val (enum, other) = List.partition (fn (Enum, _, _, _) => true + | _ => false) dts + in + (SOME (DDatatype other, #2 d), + List.revAppend (enum, enums)) + end + | DDatatypeForward (Enum, _, _) => (NONE, enums) + | _ => (SOME d, enums)) + [] ds + + val ds = (DDatatype enums, ErrorMsg.dummySpan) :: ds + + val (pds, env) = ListUtil.foldlMap (fn (d, env) => + let + val d' = p_decl env d + val hs = latestUrlHandlers () + val (protos, defs) = ListPair.unzip hs + in + (box (List.revAppend (protos, (List.revAppend (defs, [d'])))), + E.declBinds env d) + end) + env ds + + fun flatFields always (t : typ) = + case #1 t of + TRecord i => + let + val xts = E.lookupStruct env i + in + SOME ((always @ map #1 xts) :: List.concat (List.mapPartial (flatFields [] o #2) xts)) + end + | TList (_, i) => + let + val ts = E.lookupStruct env i + in + case ts of + [("1", t'), ("2", _)] => flatFields [] t' + | _ => raise Fail "CjrPrint: Bad struct for TList" + end + | _ => NONE + + val fields = foldl (fn ((ek, _, _, ts, _, _, _, _), fields) => + case ek of + Action eff => + (case List.nth (ts, length ts - 2) of + (TRecord i, loc) => + let + val xts = E.lookupStruct env i + val extra = case eff of + ReadCookieWrite => [sigName xts] + | _ => [] + in + case flatFields extra (TRecord i, loc) of + NONE => raise Fail "CjrPrint: flatFields impossible" + | SOME fields' => List.revAppend (fields', fields) + end + | _ => raise Fail "CjrPrint: Last argument of action isn't record") + | _ => fields) + [] ps + + val fields = foldl (fn (xts, fields) => + let + val xtsSet = SS.addList (SS.empty, xts) + in + foldl (fn (x, fields) => + let + val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) + in + SM.insert (fields, x, SS.union (SS.delete (xtsSet, x), + xtsSet')) + end) fields xts + end) + SM.empty fields + + val fnums = SM.foldli (fn (x, xs, fnums) => + let + val unusable = SS.foldl (fn (x', unusable) => + case SM.find (fnums, x') of + NONE => unusable + | SOME n => IS.add (unusable, n)) + IS.empty xs + + fun findAvailable n = + if IS.member (unusable, n) then + findAvailable (n + 1) + else + n + in + SM.insert (fnums, x, findAvailable 0) + end) + SM.empty fields + + val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds + + fun makeSwitch (fnums, i) = + case SM.foldl (fn (n, NotFound) => Found n + | (n, Error) => Error + | (n, Found n') => if n = n' then + Found n' + else + Error) NotFound fnums of + NotFound => box [string "return", + space, + string "-1;"] + | Found n => box [string "return", + space, + string (Int.toString n), + string ";"] + | Error => + let + val cmap = SM.foldli (fn (x, n, cmap) => + let + val ch = if i < size x then + String.sub (x, i) + else + chr 0 + + val fnums = case CM.find (cmap, ch) of + NONE => SM.empty + | SOME fnums => fnums + val fnums = SM.insert (fnums, x, n) + in + CM.insert (cmap, ch, fnums) + end) + CM.empty fnums + + val cmap = CM.listItemsi cmap + in + case cmap of + [(_, fnums)] => + box [string "if", + space, + string "(name[", + string (Int.toString i), + string "]", + space, + string "==", + space, + string "0)", + space, + string "return", + space, + string "-1;", + newline, + makeSwitch (fnums, i+1)] + | _ => + box [string "switch", + space, + string "(name[", + string (Int.toString i), + string "])", + space, + string "{", + newline, + box (map (fn (ch, fnums) => + box [string "case", + space, + if ch = chr 0 then + string "0:" + else + box [string "'", + string (Char.toString ch), + string "':"], + newline, + makeSwitch (fnums, i+1), + newline]) cmap), + string "default:", + newline, + string "return", + space, + string "-1;", + newline, + string "}"] + end + + fun getInput (x, t) = + let + val n = case SM.find (fnums, x) of + NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums") + | SOME n => n + + val f = case t of + (TFfi ("Basis", "bool"), _) => "optional_" + | _ => "" + in + if isFile t then + box [string "uw_input_", + p_ident x, + space, + string "=", + space, + string "uw_get_file_input(ctx, ", + string (Int.toString n), + string ");", + newline] + else case #1 t of + TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "uw_enter_subform(ctx, ", + string (Int.toString n), + string ");", + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + string "({", + box [p_typ env t, + space, + string "result;", + newline, + p_list_sep (box []) + (fn (x, t) => + box [p_typ env t, + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + newline, + p_list_sep (box []) (fn (x, t) => + box [getInput (x, t), + string "result.__uwf_", + string x, + space, + string "=", + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + newline, + string "result;", + newline], + string "});", + newline, + string "uw_leave_subform(ctx);"] + end + | TList (t', i) => + let + val xts = E.lookupStruct env i + val i' = case xts of + [("1", (TRecord i', loc)), ("2", _)] => i' + | _ => raise Fail "CjrPrint: Bad TList record [2]" + val xts = E.lookupStruct env i' + in + box [string "{", + newline, + string "int status;", + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + string "NULL;", + newline, + string "for (status = uw_enter_subforms(ctx, ", + string (Int.toString n), + string "); status; status = uw_next_entry(ctx)) {", + newline, + box [p_typ env t, + space, + string "result", + space, + string "=", + space, + string "uw_malloc(ctx, sizeof(struct __uws_", + string (Int.toString i), + string "));", + newline, + box [string "{", + p_list_sep (box []) + (fn (x, t) => + box [p_typ env t, + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + newline, + p_list_sep (box []) (fn (x, t) => + box [getInput (x, t), + string "result->__uwf_1.__uwf_", + string x, + space, + string "=", + space, + string "uw_input_", + string x, + string ";", + newline]) + xts, + string "}", + newline], + newline, + string "result->__uwf_2 = uw_input_", + p_ident x, + string ";", + newline, + string "uw_input_", + p_ident x, + string " = result;", + newline], + string "}}", + newline] + end + | TOption _ => + box [string "uw_input_", + p_ident x, + space, + string "=", + space, + string "uw_get_input(ctx, ", + string (Int.toString n), + string ");", + newline] + | _ => + box [string "request = uw_get_", + string f, + string "input(ctx, ", + string (Int.toString n), + string ");", + newline, + string "if (request == NULL)", + newline, + box [string "uw_error(ctx, FATAL, \"Missing input ", + string x, + string "\");"], + newline, + string "uw_input_", + p_ident x, + space, + string "=", + space, + unurlify true env t, + string ";", + newline] + end + + fun allScripts () = + foldl (fn (x, scripts) => + scripts + ^ "<script type=\\\"text/javascript\\\" src=\\\"" ^ x ^ "\\\"></script>\\n") + "" (Settings.getScripts () @ [!app_js]) + + fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) = + let + val (ts, defInputs, inputsVar, fields) = + case ek of + Core.Action _ => + (case List.nth (ts, length ts - 2) of + (TRecord i, _) => + let + val xts = E.lookupStruct env i + in + (List.take (ts, length ts - 2), + box [box (map (fn (x, t) => box [p_typ env t, + space, + string "uw_input_", + p_ident x, + string ";", + newline]) xts), + newline, + box (map getInput xts), + case i of + 0 => string "uw_unit uw_inputs;" + | _ => box [string "struct __uws_", + string (Int.toString i), + space, + string "uw_inputs", + space, + string "= {", + newline, + box (map (fn (x, _) => box [string "uw_input_", + p_ident x, + string ",", + newline]) xts), + string "};"], + newline], + box [string ",", + space, + string "uw_inputs"], + SOME xts) + end + + | _ => raise Fail "CjrPrint: Last argument to an action isn't a record") + | _ => (List.take (ts, length ts - 1), string "", string "", NONE) + + fun couldWrite ek = + case ek of + Link _ => false + | Action ef => ef = ReadCookieWrite + | Rpc ef => ef = ReadCookieWrite + | Extern _ => false + + fun couldWriteDb ek = + case ek of + Link ef => ef <> ReadOnly + | Action ef => ef <> ReadOnly + | Rpc ef => ef <> ReadOnly + | Extern ef => ef <> ReadOnly + + val s = + case Settings.getUrlPrefix () of + "" => s + | "/" => s + | prefix => + if size s > 0 andalso String.sub (s, 0) = #"/" then + prefix ^ String.extract (s, 1, NONE) + else + prefix ^ s + in + box [string "if (!strncmp(request, \"", + string (Prim.toCString s), + string "\", ", + string (Int.toString (size s)), + string ") && (request[", + string (Int.toString (size s)), + string "] == 0 || request[", + string (Int.toString (size s)), + string "] == '/')) {", + newline, + string "request += ", + string (Int.toString (size s)), + string ";", + newline, + string "if (*request == '/') ++request;", + newline, + case ek of + Rpc _ => box [string "if (uw_hasPostBody(ctx)) {", + newline, + box [string "uw_Basis_postBody pb = uw_getPostBody(ctx);", + newline, + string "if (pb.data[0])", + newline, + box [string "request = uw_Basis_strcat(ctx, request, pb.data);"], + newline], + string "}", + newline] + | _ => box [], + if couldWrite ek andalso not (Settings.checkNoXsrfProtection s) then + box [string "{", + newline, + string "uw_Basis_string sig = ", + case fields of + NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")" + | SOME fields => + case SM.find (fnums, sigName fields) of + NONE => raise Fail "CjrPrint: sig name wasn't assigned a number" + | SOME inum => + string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"), + string ";", + newline, + string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");", + newline, + string "if (!uw_streq(sig, uw_cookie_sig(ctx)))", + newline, + box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");", + newline], + string "}", + newline] + else + box [], + box (case ek of + Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");", + newline] + | _ => [string "uw_write_header(ctx, \"Content-type: text/html; charset=utf-8\\r\\n\");", + newline, + case side of + ServerOnly => box [] + | _ => box [string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline], + string ("uw_write(ctx, uw_begin_" ^ + (if Settings.getIsHtml5 () then + "html5" + else + "xhtml") ^ ");"), + newline, + string "uw_mayReturnIndirectly(ctx);", + newline, + string "uw_set_script_header(ctx, \"", + let + val scripts = + case side of + ServerOnly => "" + | _ => allScripts () + in + string scripts + end, + string "\");", + newline]), + string "uw_set_could_write_db(ctx, ", + string (if couldWriteDb ek then "1" else "0"), + string ");", + newline, + string "uw_set_at_most_one_query(ctx, ", + string (case dbmode of OneQuery => "1" | _ => "0"), + string ");", + newline, + string "uw_set_needs_push(ctx, ", + string (case side of + ServerAndPullAndPush => "1" + | _ => "0"), + string ");", + newline, + string "uw_set_needs_sig(ctx, ", + string (if tellSig then + "1" + else + "0"), + string ");", + newline, + string "uw_login(ctx);", + newline, + box [string "{", + newline, + box (ListUtil.mapi (fn (i, t) => box [p_typ env t, + space, + string "arg", + string (Int.toString i), + space, + string "=", + space, + case #1 t of + TFfi ("Basis", "postBody") => string "uw_getPostBody(ctx)" + | TOption (TFfi ("Basis", "queryString"), _) => string "uw_queryString(ctx)" + | _ => unurlify false env t, + string ";", + newline]) ts), + defInputs, + box (case ek of + Core.Rpc _ => [p_typ env ran, + space, + string "it0", + space, + string "=", + space] + | _ => []), + p_enamed env n, + string "(", + p_list_sep (box [string ",", space]) + (fn x => x) + (string "ctx" + :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts), + inputsVar, + string ", 0);", + newline, + box (case ek of + Core.Rpc _ => [string "uw_write(ctx, uw_get_real_script(ctx));", + newline, + string "uw_write(ctx, \"\\n\");", + newline, + urlify env ran] + | _ => [string "uw_write(ctx, \"</html>\");", + newline]), + string "return;", + newline, + string "}", + newline, + string "}"] + ] + end + + val (pds', handlers) = ListUtil.foldlMap (fn (p, handlers) => + let + val p' = p_page p + in + (p', latestUrlHandlers () @ handlers) + end) [] ps + val (protos, defs) = ListPair.unzip handlers + + val hasDb = ref false + val tables = ref [] + val views = ref [] + val sequences = ref [] + val dbstring = ref "" + val expunge = ref 0 + val initialize = ref 0 + val prepped = ref [] + val hasJs = ref false + + val _ = foldl (fn (d, env) => + ((case #1 d of + 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 + | DView (s, xts, _) => views := (s, map (fn (x, t) => + (x, sql_type_in env t)) xts) :: !views + | DSequence s => sequences := s :: !sequences + | DPreparedStatements ss => prepped := ss + | _ => ()); + E.declBinds env d)) E.empty ds + + val hasDb = !hasDb + + fun expDb (e, _) = + case e of + ECon (_, _, SOME e) => expDb e + | ESome (_, e) => expDb e + | EFfiApp (_, _, es) => List.exists (expDb o #1) es + | EApp (e, es) => expDb e orelse List.exists expDb es + | EUnop (_, e) => expDb e + | EBinop (_, e1, e2) => expDb e1 orelse expDb e2 + | ERecord (_, xes) => List.exists (expDb o #2) xes + | EField (e, _) => expDb e + | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes + | EError (e, _) => expDb e + | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 + | ERedirect (e, _) => expDb e + | EWrite e => expDb e + | ESeq (e1, e2) => expDb e1 orelse expDb e2 + | ELet (_, _, e1, e2) => expDb e1 orelse expDb e2 + | EQuery _ => true + | EDml _ => true + | ENextval _ => true + | ESetval _ => true + | EUnurlify (e, _, _) => expDb e + | _ => false + + fun declDb (d, _) = + case d of + DVal (_, _, _, e) => expDb e + | DFun (_, _, _, _, e) => expDb e + | DFunRec vis => List.exists (expDb o #5) vis + | DTask (_, _, _, e) => expDb e + | _ => false + + val () = if not hasDb andalso List.exists declDb ds then + ErrorMsg.error "Application uses a database but has none configured with 'database' in .urp file." + else + () + + val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds + + val cookieCode = foldl (fn (cookie, acc) => + SOME (case acc of + NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \"" + ^ cookie ^ "\"))") + | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \"" + ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "), + acc, + string "))"])) + NONE cookies + + val cookieCode = foldl (fn (evar, acc) => + SOME (case acc of + NONE => string ("uw_unnull(uw_Basis_getenv(ctx, \"" + ^ Prim.toCString evar ^ "\"))") + | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_getenv(ctx, \"" + ^ Prim.toCString evar ^ "\")), uw_Basis_strcat(ctx, \"/\", "), + acc, + string "))"])) + cookieCode (SideCheck.readEnvVars ()) + + fun makeChecker (name, rules : Settings.rule list) = + box [string "static int ", + string name, + string "(const char *s) {", + newline, + box [p_list_sep (box []) + (fn rule => + box [string "if (!str", + case #kind rule of + Settings.Exact => box [string "cmp(s, \"", + string (Prim.toCString (#pattern rule)), + string "\"))"] + | Settings.Prefix => box [string "ncmp(s, \"", + string (Prim.toCString (#pattern rule)), + string "\", ", + string (Int.toString (size (#pattern rule))), + string "))"], + string " return ", + string (case #action rule of + Settings.Allow => "1" + | Settings.Deny => "0"), + string ";", + newline]) rules, + string "return 0;", + newline], + 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 onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds + + val lastMod = Date.fromTimeUniv (FileIO.mostRecentModTime ()) + val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT" + + fun hexifyByte (b : Word8.word) : string = + let + val s = Int.fmt StringCvt.HEX (Word8.toInt b) + in + "\\x" ^ (if size s < 2 then "0" else "") ^ s + end + + fun hexify (v : Word8Vector.vector) : string = + String.concat (Word8Vector.foldr (fn (b, ls) => + hexifyByte b :: ls) [] v) + in + box [string "#include \"", + string (OS.Path.joinDirFile {dir = !Settings.configInclude, + file = "config.h"}), + string "\"", + newline, + string "#include <stdio.h>", + newline, + string "#include <stdlib.h>", + newline, + string "#include <string.h>", + newline, + string "#include <math.h>", + newline, + string "#include <time.h>", + newline, + if hasDb then + box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), + newline] + else + box [], + p_list_sep (box []) (fn s => box [string "#include \"", + string s, + string "\"", + newline]) (Settings.getHeaders ()), + string "#include \"", + string (OS.Path.joinDirFile {dir = !Settings.configInclude, + file = "urweb.h"}), + string "\"", + newline, + newline, + + box [string "static void uw_setup_limits() {", + newline, + case Settings.getMinHeap () of + 0 => box [] + | n => box [string "uw_min_heap", + space, + string "=", + space, + string (Int.toString n), + string ";", + newline, + newline], + box [p_list_sep (box []) (fn (class, num) => + let + val num = case class of + "page" => Int.max (2048, num) + | _ => num + in + box [string ("uw_" ^ class ^ "_max"), + space, + string "=", + space, + string (Int.toString num), + string ";", + newline] + end) (Settings.limits ())], + string "}", + newline, + newline], + + #code (Settings.currentProtocol ()) (), + + if hasDb then + #init (Settings.currentDbms ()) {dbstring = !dbstring, + prepared = !prepped, + tables = !tables, + views = !views, + sequences = !sequences} + else + box [string "static void uw_client_init(void) { };", + newline, + string "static void uw_db_init(uw_context ctx) { };", + newline, + string "static int uw_db_begin(uw_context ctx, int could_write) { return 0; };", + newline, + string "static void uw_db_close(uw_context ctx) { };", + newline, + string "static int uw_db_commit(uw_context ctx) { return 0; };", + newline, + string "static int uw_db_rollback(uw_context ctx) { return 0; };"], + newline, + newline, + + (* For sqlcache. *) + let + val {setupGlobal, setupQuery, ...} = Sqlcache.getCache () + in + box (setupGlobal :: newline :: List.map setupQuery (Sqlcache.getFfiInfo ())) + end, + newline, + + p_list_sep newline (fn x => x) pds, + newline, + newline, + string "static int uw_input_num(const char *name) {", + newline, + makeSwitch (fnums, 0), + string "}", + newline, + newline, + + box (ListUtil.mapi (fn (i, (_, x1, x2, e)) => + box [string "static void uw_periodic", + string (Int.toString i), + string "(uw_context ctx) {", + newline, + box [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, + newline]) periodics), + + string "static uw_periodic my_periodics[] = {", + box (ListUtil.mapi (fn (i, (n, _, _, _)) => + box [string "{uw_periodic", + string (Int.toString i), + string ",", + space, + string (Int64.toString n), + string "},"]) periodics), + string "{NULL}};", + newline, + newline, + + makeChecker ("uw_check_url", Settings.getUrlRules ()), + newline, + + makeChecker ("uw_check_mime", Settings.getMimeRules ()), + newline, + + makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()), + newline, + + makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()), + newline, + + makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()), + newline, + + makeChecker ("uw_check_meta", Settings.getMetaRules ()), + newline, + + string "extern void uw_sign(const char *in, char *out);", + newline, + string "extern int uw_hash_blocksize;", + newline, + string "static uw_Basis_string uw_cookie_sig(uw_context ctx) {", + newline, + box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);", + newline, + string "uw_sign(", + case cookieCode of + NONE => string "\"\"" + | SOME code => code, + string ", r);", + newline, + string "return uw_Basis_makeSigString(ctx, r);", + newline], + string "}", + newline, + newline, + + box (rev protos), + box (rev defs), + + string "static void uw_handle(uw_context ctx, char *request) {", + newline, + string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");", + newline, + string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt lastMod ^ "\")) {"), + newline, + box [string "uw_clear_headers(ctx);", + newline, + string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");", + newline, + string "return;", + newline], + string "}", + newline, + newline, + string "if (!strcmp(request, \"", + string (!app_js), + string "\")) {", + newline, + box [string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");", + newline, + string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt lastMod ^ "\\r\\n\");"), + newline, + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + newline, + string "uw_write(ctx, jslib);", + newline, + string "return;", + newline], + string "}", + newline, + newline, + + p_list_sep newline (fn r => + box [string "if (!strcmp(request, \"", + string (String.toCString (#Uri r)), + string "\")) {", + newline, + box [(case #ContentType r of + NONE => box [] + | SOME ct => box [string "uw_write_header(ctx, \"Content-Type: ", + string (String.toCString ct), + string "\\r\\n\");", + newline]), + string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt lastMod ^ "\\r\\n\");"), + newline, + string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), + newline, + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + newline, + string "uw_replace_page(ctx, \"", + string (hexify (#Bytes r)), + string "\", ", + string (Int.toString (Word8Vector.length (#Bytes r))), + string ");", + newline, + string "return;", + newline], + string "};", + newline]) (Settings.listFiles ()), + + newline, + p_list_sep newline (fn x => x) pds', + newline, + string "uw_clear_headers(ctx);", + newline, + string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 404 Not Found\\r\\n\" : \"Status: 404 Not Found\\r\\n\");", + newline, + string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");", + newline, + string "uw_write(ctx, \"Not Found\");", + newline, + string "}", + newline, + newline, + + 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, + + if hasDb then + box [p_enamed env (!expunge), + string "(ctx, cli);", + newline] + else + box [], + string "}"], + + newline, + string "static void uw_initializer(uw_context ctx) {", + newline, + box [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, + if hasDb then + box [p_enamed env (!initialize), + string "(ctx, 0);", + newline] + else + box []], + string "}", + newline, + + case onError of + NONE => box [] + | SOME n => box [string "static void uw_onError(uw_context ctx, char *msg) {", + newline, + if !hasJs then + box [string "uw_set_script_header(ctx, \"", + string (allScripts ()), + string "\");", + newline] + else + box [], + box [string "uw_write(ctx, ", + p_enamed env n, + string "(ctx, msg, 0));", + newline], + string "}", + newline, + newline], + + string "uw_app uw_application = {", + p_list_sep (box [string ",", newline]) string + [Int.toString (SM.foldl Int.max 0 fnums + 1), + Int.toString (Settings.getTimeout ()), + "\"" ^ Settings.getUrlPrefix () ^ "\"", + "uw_client_init", "uw_initializer", "uw_expunger", + "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", + "uw_handle", + "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", "uw_check_meta", + case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics", + "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"", + if Settings.getIsHtml5 () then "1" else "0"], + string "};", + newline] + end + +fun p_sql env (ds, _) = + let + val (pps, _) = ListUtil.foldlMap + (fn (dAll as (d, _), env) => + let + val pp = case d of + DTable (s, xts, pk, csts) => + box [string "CREATE TABLE ", + string s, + string "(", + p_list (fn (x, t) => + let + val t = sql_type_in env t + in + box [string (Settings.mangleSql (CharVector.map Char.toLower x)), + space, + string (#p_sql_type (Settings.currentDbms ()) t), + case t of + Nullable _ => box [] + | _ => string " NOT NULL"] + end) xts, + case (pk, csts) of + ("", []) => box [] + | _ => string ",", + cut, + case pk of + "" => box [] + | _ => box [string "PRIMARY", + space, + string "KEY", + space, + string "(", + string pk, + string ")", + case csts of + [] => box [] + | _ => string ",", + newline], + p_list_sep (box [string ",", newline]) + (fn (x, c) => + box [string "CONSTRAINT", + space, + string s, + string "_", + string x, + space, + string c]) csts, + newline, + string ");", + newline, + newline] + | DSequence s => + box [string (#createSequence (Settings.currentDbms ()) s), + string ";", + newline, + newline] + | DView (s, xts, q) => + box [string "CREATE VIEW", + space, + string s, + space, + string "AS", + space, + string q, + string ";", + newline, + newline] + | _ => box [] + in + (pp, E.declBinds env dAll) + end) + env ds + in + box (string (#sqlPrefix (Settings.currentDbms ())) :: pps) + end + +end diff --git a/src/cjrize.sig b/src/cjrize.sig new file mode 100644 index 0000000..fb8d37f --- /dev/null +++ b/src/cjrize.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 CJRIZE = sig + + val cjrize : Mono.file -> Cjr.file + +end diff --git a/src/cjrize.sml b/src/cjrize.sml new file mode 100644 index 0000000..fbc7eba --- /dev/null +++ b/src/cjrize.sml @@ -0,0 +1,745 @@ +(* 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 Cjrize :> CJRIZE = struct + +structure L = Mono +structure L' = Cjr + +structure IM = IntBinaryMap + +structure Sm :> sig + type t + + val empty : t + val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int + val findList : t * L.typ * L'.typ -> t * int + + val declares : t -> (int * (string * L'.typ) list) list + val clearDeclares : t -> t +end = struct + +structure FM = BinaryMapFn(struct + type ord_key = L.typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + normal : int FM.map, + lists : int FM.map, + decls : (int * (string * L'.typ) list) list +} + +val empty : t = { + count = 1, + normal = FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), + lists = FM.empty, + decls = [] +} + +fun find (v as {count, normal, decls, lists}, xts, xts') = + let + val t = (L.TRecord xts, ErrorMsg.dummySpan) + in + case FM.find (normal, t) of + SOME i => (v, i) + | NONE => ({count = count+1, + normal = FM.insert (normal, t, count), + lists = lists, + decls = (count, xts') :: decls}, + count) + end + +fun findList (v as {count, normal, decls, lists}, t, t') = + case FM.find (lists, t) of + SOME i => (v, i) + | NONE => + let + val xts = [("1", t), ("2", (L.TList t, #2 t))] + val xts' = [("1", t'), ("2", (L'.TList (t', count), #2 t'))] + in + ({count = count+1, + normal = FM.insert (normal, (L.TRecord xts, ErrorMsg.dummySpan), count), + lists = FM.insert (lists, t, count), + decls = (count, xts') :: decls}, + count) + end + +fun declares (v : t) = #decls v + +fun clearDeclares (v : t) = {count = #count v, + normal = #normal v, + lists = #lists v, + decls = []} + +end + +fun cifyTyp x = + let + fun cify dtmap ((t, loc), sm) = + case t of + L.TFun (t1, t2) => + let + val (t1, sm) = cify dtmap (t1, sm) + val (t2, sm) = cify dtmap (t2, sm) + in + ((L'.TFun (t1, t2), loc), sm) + end + | L.TRecord xts => + let + val xts = MonoUtil.Typ.sortFields xts + val old_xts = xts + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cify dtmap (t, sm) + in + ((x, t), sm) + end) + sm xts + val (sm, si) = Sm.find (sm, old_xts, xts) + in + ((L'.TRecord si, loc), sm) + end + | L.TDatatype (n, ref (dk, xncs)) => + (case IM.find (dtmap, n) of + SOME r => ((L'.TDatatype (dk, n, r), loc), sm) + | NONE => + let + val r = ref [] + val dtmap = IM.insert (dtmap, n, r) + + val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => + case to of + NONE => ((x, n, NONE), sm) + | SOME t => + let + val (t, sm) = cify dtmap (t, sm) + in + ((x, n, SOME t), sm) + end) + sm xncs + in + r := xncs; + ((L'.TDatatype (dk, n, r), loc), sm) + end) + | L.TFfi mx => ((L'.TFfi mx, loc), sm) + | L.TOption t => + let + val (t, sm) = cify dtmap (t, sm) + in + ((L'.TOption t, loc), sm) + end + | L.TList t => + let + val (t', sm) = cify dtmap (t, sm) + val (sm, si) = Sm.findList (sm, t, t') + in + ((L'.TList (t', si), loc), sm) + end + | L.TSource => ((L'.TFfi ("Basis", "source"), loc), sm) + | L.TSignal _ => (ErrorMsg.errorAt loc "TSignal remains"; + Print.epreface ("Full type", MonoPrint.p_typ MonoEnv.empty (#1 x)); + ((L'.TFfi ("Basis", "bogus"), loc), sm)) + in + cify IM.empty x + end + +val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) + +fun cifyPatCon (pc, sm) = + case pc of + L.PConVar n => (L'.PConVar n, sm) + | L.PConFfi {mod = m, datatyp, con, arg} => + let + val (arg, sm) = + case arg of + NONE => (NONE, sm) + | SOME t => + let + val (t, sm) = cifyTyp (t, sm) + in + (SOME t, sm) + end + in + (L'.PConFfi {mod = m, datatyp = datatyp, con = con, arg = arg}, sm) + end + +fun cifyPat ((p, loc), sm) = + case p of + L.PVar (x, t) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((L'.PVar (x, t), loc), sm) + end + | L.PPrim p => ((L'.PPrim p, loc), sm) + | L.PCon (dk, pc, NONE) => + let + val (pc, sm) = cifyPatCon (pc, sm) + in + ((L'.PCon (dk, pc, NONE), loc), sm) + end + | L.PCon (dk, pc, SOME p) => + let + val (pc, sm) = cifyPatCon (pc, sm) + val (p, sm) = cifyPat (p, sm) + in + ((L'.PCon (dk, pc, SOME p), loc), sm) + end + | L.PRecord xps => + let + val (xps, sm) = ListUtil.foldlMap (fn ((x, p, t), sm) => + let + val (p, sm) = cifyPat (p, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((x, p, t), sm) + end) sm xps + in + ((L'.PRecord xps, loc), sm) + end + | L.PNone t => + let + val (t, sm) = cifyTyp (t, sm) + in + ((L'.PNone t, loc), sm) + end + | L.PSome (t, p) => + let + val (t, sm) = cifyTyp (t, sm) + val (p, sm) = cifyPat (p, sm) + in + ((L'.PSome (t, p), loc), sm) + end + +fun cifyExp (eAll as (e, loc), sm) = + let + fun fail msg = + (ErrorMsg.errorAt loc msg; + ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm)) + in + case e of + L.EPrim p => ((L'.EPrim p, loc), sm) + | L.ERel n => ((L'.ERel n, loc), sm) + | L.ENamed n => ((L'.ENamed n, loc), sm) + | L.ECon (dk, pc, eo) => + let + val (eo, sm) = + case eo of + NONE => (NONE, sm) + | SOME e => + let + val (e, sm) = cifyExp (e, sm) + in + (SOME e, sm) + end + val (pc, sm) = cifyPatCon (pc, sm) + in + ((L'.ECon (dk, pc, eo), loc), sm) + end + | L.ENone t => + let + val (t, sm) = cifyTyp (t, sm) + in + ((L'.ENone t, loc), sm) + end + | L.ESome (t, e) => + let + val (t, sm) = cifyTyp (t, sm) + val (e, sm) = cifyExp (e, sm) + in + ((L'.ESome (t, e), loc), sm) + end + | L.EFfi mx => ((L'.EFfi mx, loc), sm) + | L.EFfiApp (m, x, es) => + let + val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + val (e, sm) = cifyExp (e, sm) + in + ((e, t), sm) + end) sm es + in + ((L'.EFfiApp (m, x, es), loc), sm) + end + | L.EApp (e1, e2) => + let + fun unravel (e, args) = + case e of + (L.EApp (e1, e2), _) => unravel (e1, e2 :: args) + | _ => (e, args) + + val (f, es) = unravel (e1, [e2]) + + val (f, sm) = cifyExp (f, sm) + val (es, sm) = ListUtil.foldlMap cifyExp sm es + in + ((L'.EApp (f, es), loc), sm) + end + | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation"; + Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)]; + (dummye, sm)) + + | L.EUnop (s, e1) => + let + val (e1, sm) = cifyExp (e1, sm) + in + ((L'.EUnop (s, e1), loc), sm) + end + | L.EBinop (_, s, e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.EBinop (s, e1, e2), loc), sm) + end + + | L.ERecord xes => + let + val old_xts = map (fn (x, _, t) => (x, t)) xes + + val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((x, e, t), sm) + end) + sm xes + + val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets) + + val xes = map (fn (x, e, _) => (x, e)) xets + val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes + in + ((L'.ERecord (si, xes), loc), sm) + end + | L.EField (e, x) => + let + val (e, sm) = cifyExp (e, sm) + in + ((L'.EField (e, x), loc), sm) + end + + | L.ECase (e, pes, {disc, result}) => + let + val (e, sm) = cifyExp (e, sm) + val (pes, sm) = ListUtil.foldlMap + (fn ((p, e), sm) => + let + val (e, sm) = cifyExp (e, sm) + val (p, sm) = cifyPat (p, sm) + in + ((p, e), sm) + end) sm pes + val (disc, sm) = cifyTyp (disc, sm) + val (result, sm) = cifyTyp (result, sm) + in + ((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm) + end + + | L.EError (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EError (e, t), loc), sm) + end + | L.EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, sm) = cifyExp (mimeType, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm) + end + | L.EReturnBlob {blob = SOME blob, mimeType, t} => + let + val (blob, sm) = cifyExp (blob, sm) + val (mimeType, sm) = cifyExp (mimeType, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm) + end + | L.ERedirect (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.ERedirect (e, t), loc), sm) + end + + | L.EStrcat (e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm) + end + + | L.EWrite e => + let + val (e, sm) = cifyExp (e, sm) + in + ((L'.EWrite e, loc), sm) + end + + | L.ESeq (e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ESeq (e1, e2), loc), sm) + end + + | L.ELet (x, t, e1, e2) => + let + val (t, sm) = cifyTyp (t, sm) + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ELet (x, t, e1, e2), loc), sm) + end + + | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; + (dummye, sm)) + + | L.EQuery {exps, tables, state, query, body, initial} => + let + val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm exps + val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) => + let + val (xts, sm) = ListUtil.foldlMap + (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + in + ((x, xts), sm) + end) sm tables + + val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables + val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row + + val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) => + let + val (sm, rnum) = Sm.find (sm, xts, xts') + in + ((x, rnum), sm) + end) + sm (ListPair.zip (tables, tables')) + val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows + val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row' + + val (sm, rnum) = Sm.find (sm, row, row') + + val (state, sm) = cifyTyp (state, sm) + val (query, sm) = cifyExp (query, sm) + val (body, sm) = cifyExp (body, sm) + val (initial, sm) = cifyExp (initial, sm) + in + ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state, + query = query, body = body, initial = initial, prepared = NONE}, loc), sm) + end + + | L.EDml (e, mode) => + let + val (e, sm) = cifyExp (e, sm) + in + ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm) + end + + | L.ENextval e => + let + val (e, sm) = cifyExp (e, sm) + in + ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) + end + | L.ESetval (e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ESetval {seq = e1, count = e2}, loc), sm) + end + + | L.EUnurlify (e, t, b) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EUnurlify (e, t, b), loc), sm) + end + + | L.EJavaScript _ => fail "Uncompilable JavaScript remains" + + | L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code" + | L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code" + | L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code" + + | L.EServerCall _ => fail "RPC in server-side code" + | L.ERecv _ => fail "Message receive in server-side code" + | L.ESleep _ => fail "Sleep in server-side code" + | L.ESpawn _ => fail "Thread spawn in server-side code" + end + +fun cifyDecl ((d, loc), sm) = + case d of + L.DDatatype dts => + let + val (dts, sm) = ListUtil.foldlMap + (fn ((x, n, xncs), sm) => + let + val dk = ElabUtil.classifyDatatype xncs + val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => + case to of + NONE => ((x, n, NONE), sm) + | SOME t => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, n, SOME t), sm) + end) sm xncs + in + ((dk, x, n, xncs), sm) + end) + sm dts + in + (SOME (L'.DDatatype dts, loc), NONE, sm) + end + + | L.DVal (x, n, t, e, _) => + let + val (t, sm) = cifyTyp (t, sm) + + val (d, sm) = case #1 t of + L'.TFun _ => + let + fun unravel (tAll as (t, _), eAll as (e, _)) = + case (t, e) of + (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) => + let + val (args, t, e) = unravel (ran, e) + in + ((ax, dom) :: args, t, e) + end + | (L'.TFun (dom, ran), _) => + let + val e = MonoEnv.liftExpInExp 0 eAll + val e = (L.EApp (e, (L.ERel 0, loc)), loc) + val (args, t, e) = unravel (ran, e) + in + (("x", dom) :: args, t, e) + end + | _ => ([], tAll, eAll) + + val (args, ran, e) = unravel (t, e) + val (e, sm) = cifyExp (e, sm) + in + (L'.DFun (x, n, args, ran, e), sm) + end + + | _ => + let + val (e, sm) = cifyExp (e, sm) + in + (L'.DVal (x, n, t, e), sm) + end + in + (SOME (d, loc), NONE, sm) + end + | L.DValRec vis => + let + val (vis, sm) = ListUtil.foldlMap + (fn ((x, n, t, e, _), sm) => + let + val (t, sm) = cifyTyp (t, sm) + + fun unravel (tAll as (t, _), eAll as (e, _)) = + case (t, e) of + (L'.TFun (dom, ran), L.EAbs (ax, _, _, e)) => + let + val (args, t, e) = unravel (ran, e) + in + ((ax, dom) :: args, t, e) + end + | (L'.TFun _, _) => + (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; + ([], tAll, eAll)) + | _ => ([], tAll, eAll) + + val (args, ran, e) = unravel (t, e) + val (e, sm) = cifyExp (e, sm) + in + ((x, n, args, ran, e), sm) + end) + sm vis + in + (SOME (L'.DFunRec vis, loc), NONE, sm) + end + + | L.DExport (ek, s, n, ts, t, b) => + let + val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts + val (t, sm) = cifyTyp (t, sm) + in + (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush, b), sm) + end + + | L.DTable (s, xts, pe, ce) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) + + val pe = case #1 pe of + L.EPrim (Prim.String (_, s)) => s + | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty pe)]; + "") + in + (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm) + end + | L.DSequence s => + (SOME (L'.DSequence s, loc), NONE, sm) + | L.DView (s, xts, e) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) + + val e = case #1 e of + L.EPrim (Prim.String (_, s)) => s + | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; + Print.prefaces "Undetermined VIEW query" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + "") + in + (SOME (L'.DView (s, xts, e), loc), NONE, sm) + end + | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) + | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) + | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm) + | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) + | L.DTask (e1, e2) => + (case #1 e2 of + L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) => + let + val tk = case #1 e1 of + L.EFfi ("Basis", "initialize") => L'.Initialize + | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves + | L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n + | _ => (ErrorMsg.errorAt loc "Task kind not fully determined"; + L'.Initialize) + val (e, sm) = cifyExp (e, sm) + in + (SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm) + end + | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined"; + (NONE, NONE, sm))) + | L.DPolicy _ => (NONE, NONE, sm) + | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) + +fun cjrize (ds, sideInfo) = + let + val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => + let + val (dop, pop, sm) = cifyDecl (d, sm) + + val dsF = case dop of + SOME (L'.DDatatype dts, loc) => + map (fn (dk, x, n, _) => + (L'.DDatatypeForward (dk, x, n), loc)) dts @ dsF + | _ => dsF + + val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm) + @ dsF + + val (dsF, ds) = case dop of + NONE => (dsF, ds) + | SOME (d as (L'.DDatatype _, loc)) => + (d :: dsF, ds) + | SOME d => (dsF, d :: ds) + + val ps = case pop of + NONE => ps + | SOME p => p :: ps + in + (dsF, ds, ps, Sm.clearDeclares sm) + end) + ([], [], [], Sm.empty) ds + + val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo + + val ps = map (fn (ek, s, n, ts, t, _, b) => + let + val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb)) + in + (ek, s, n, ts, t, side, db, b) + end) ps + in + (List.revAppend (dsF, rev ds), + ps) + end + +end diff --git a/src/compiler.mlb b/src/compiler.mlb new file mode 100644 index 0000000..04a5871 --- /dev/null +++ b/src/compiler.mlb @@ -0,0 +1,6 @@ +$(SML_LIB)/basis/basis.mlb +$(SML_LIB)/basis/mlton.mlb + +$(BUILD)/urweb.mlb + +main.mlton.sml diff --git a/src/compiler.sig b/src/compiler.sig new file mode 100644 index 0000000..952c707 --- /dev/null +++ b/src/compiler.sig @@ -0,0 +1,213 @@ +(* Copyright (c) 2008-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. + *) + +(* Ur/Web main compiler interface *) + +signature COMPILER = sig + + type job = { + prefix : string, + database : string option, + sources : string list, + exe : string, + sql : string option, + debug : bool, + profile : bool, + timeout : int, + ffi : string list, + link : string list, + linker : string option, + headers : string list, + scripts : string list, + clientToServer : Settings.ffi list, + effectful : Settings.ffi list, + benignEffectful : Settings.ffi list, + clientOnly : Settings.ffi list, + serverOnly : Settings.ffi list, + jsModule : string option, + jsFuncs : (Settings.ffi * string) list, + rewrites : Settings.rewrite list, + filterUrl : Settings.rule list, + filterMime : Settings.rule list, + filterRequest : Settings.rule list, + filterResponse : Settings.rule list, + filterEnv : Settings.rule list, + filterMeta : Settings.rule list, + protocol : string option, + dbms : string option, + sigFile : string option, + safeGets : string list, + onError : (string * string list * string) option, + minHeap : int + } + val compile : string -> bool + val compiler : string -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string, + profile : bool, debug : bool, linker : string option, link : string list} -> bool + + val beforeC : (unit -> unit) ref + (* This function is called before beginning C compilation. + * The current use is for MLton to compact its heap here, to avoid hogging + * space after all the interesting ML code is done. *) + + type ('src, 'dst) phase + type ('src, 'dst) transform + + val transform : ('src, 'dst) phase -> string -> ('src, 'dst) transform + val o : ('b, 'c) transform * ('a, 'b) transform -> ('a, 'c) transform + + val check : ('src, 'dst) transform -> 'src -> unit + val run : ('src, 'dst) transform -> 'src -> 'dst option + val runPrint : ('src, 'dst) transform -> 'src -> unit + val runPrintToFile : ('src, 'dst) transform -> 'src -> string -> unit + val time : ('src, 'dst) transform -> 'src -> unit + val timePrint : ('src, 'dst) transform -> 'src -> unit + + val runPrintCoreFuncs : ('src, Core.file) transform -> 'src -> unit + + val parseUr : (string, Source.file) phase + val parseUrs : (string, Source.sgn_item list) phase + val parseUrp : (string, job) phase + val parseUrp' : (string, {Job : job, Libs : string list}) phase + + val parse : (job, Source.file) phase + val elaborate : (Source.file, Elab.file) phase + val unnest : (Elab.file, Elab.file) phase + val termination : (Elab.file, Elab.file) phase + val explify : (Elab.file, Expl.file) phase + val corify : (Expl.file, Core.file) phase + val core_untangle : (Core.file, Core.file) phase + val shake : (Core.file, Core.file) phase + val rpcify : (Core.file, Core.file) phase + val tag : (Core.file, Core.file) phase + val reduce : (Core.file, Core.file) phase + val unpoly : (Core.file, Core.file) phase + val especialize : (Core.file, Core.file) phase + val specialize : (Core.file, Core.file) phase + val marshalcheck : (Core.file, Core.file) phase + val effectize : (Core.file, Core.file) phase + val css : (Core.file, Css.report) phase + val monoize : (Core.file, Mono.file) phase + val mono_opt : (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 + val iflow : (Mono.file, Mono.file) phase + val namejs : (Mono.file, Mono.file) phase + val scriptcheck : (Mono.file, Mono.file) phase + val jscomp : (Mono.file, Mono.file) phase + val fuse : (Mono.file, Mono.file) phase + val pathcheck : (Mono.file, Mono.file) phase + val sidecheck : (Mono.file, Mono.file) phase + val sigcheck : (Mono.file, Mono.file) phase + val sqlcache : (Mono.file, Mono.file) phase + val cjrize : (Mono.file, Cjr.file) phase + val prepare : (Cjr.file, Cjr.file) phase + val checknest : (Cjr.file, Cjr.file) phase + val sqlify : (Mono.file, Cjr.file) phase + + val toParseJob : (string, job) transform + val toParseJob' : (string, {Job : job, Libs : string list}) transform + val toParse : (string, Source.file) transform + val toElaborate : (string, Elab.file) transform + val toUnnest : (string, Elab.file) transform + val toTermination : (string, Elab.file) transform + val toExplify : (string, Expl.file) transform + val toCorify : (string, Core.file) transform + val toCore_untangle : (string, Core.file) transform + val toShake1 : (string, Core.file) transform + val toEspecialize1' : (string, Core.file) transform + val toShake1' : (string, Core.file) transform + val toRpcify : (string, Core.file) transform + val toCore_untangle2 : (string, Core.file) transform + val toShake2 : (string, Core.file) transform + val toEspecialize1 : (string, Core.file) transform + val toCore_untangle3 : (string, Core.file) transform + val toShake3 : (string, Core.file) transform + val toTag : (string, Core.file) transform + val toReduce : (string, Core.file) transform + val toShakey : (string, Core.file) transform + val toUnpoly : (string, Core.file) transform + val toSpecialize : (string, Core.file) transform + val toShake4 : (string, Core.file) transform + val toEspecialize2 : (string, Core.file) transform + val toShake4' : (string, Core.file) transform + val toSpecialize2 : (string, Core.file) transform + val toUnpoly2 : (string, Core.file) transform + val toShake4'' : (string, Core.file) transform + val toEspecialize3 : (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 toMono_opt1 : (string, Mono.file) transform + val toUntangle : (string, Mono.file) transform + val toMono_reduce : (string, Mono.file) transform + val toMono_shake : (string, Mono.file) transform + val toMono_opt2 : (string, Mono.file) transform + val toIflow : (string, Mono.file) transform + val toNamejs : (string, Mono.file) transform + val toNamejs_untangle : (string, Mono.file) transform + val toScriptcheck : (string, Mono.file) transform + val toDbmodecheck : (string, Mono.file) transform + val toJscomp : (string, Mono.file) transform + val toMono_opt3 : (string, Mono.file) transform + val toFuse : (string, Mono.file) transform + val toUntangle2 : (string, Mono.file) transform + val toMono_reduce2 : (string, Mono.file) transform + val toMono_shake2 : (string, Mono.file) transform + val toMono_opt4 : (string, Mono.file) transform + val toMono_reduce3 : (string, Mono.file) transform + val toFuse2 : (string, Mono.file) transform + val toUntangle3 : (string, Mono.file) transform + val toMono_shake3 : (string, Mono.file) transform + val toPathcheck : (string, Mono.file) transform + val toSidecheck : (string, Mono.file) transform + val toSigcheck : (string, Mono.file) transform + val toSqlcache : (string, Mono.file) transform + val toCjrize : (string, Cjr.file) transform + val toPrepare : (string, Cjr.file) transform + val toChecknest : (string, Cjr.file) transform + val toSqlify : (string, Cjr.file) transform + + val debug : bool ref + val dumpSource : bool ref + val enableBoot : unit -> unit + + val doIflow : bool ref + + val addPath : string * string -> unit + val addModuleRoot : string * string -> unit + + val moduleOf : string -> string + + val setStop : string -> unit + (* Stop compilation after this phase. *) + +end diff --git a/src/compiler.sml b/src/compiler.sml new file mode 100644 index 0000000..c13de30 --- /dev/null +++ b/src/compiler.sml @@ -0,0 +1,1716 @@ +(* Copyright (c) 2008-2012, 2014, 2016, 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 Compiler :> COMPILER = struct + +structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token) +structure Lex = UrwebLexFn(structure Tokens = UrwebLrVals.Tokens) +structure UrwebP = Join(structure ParserData = UrwebLrVals.ParserData + structure Lex = Lex + structure LrParser = LrParser) + +type job = { + prefix : string, + database : string option, + sources : string list, + exe : string, + sql : string option, + debug : bool, + profile : bool, + timeout : int, + ffi : string list, + link : string list, + linker : string option, + headers : string list, + scripts : string list, + clientToServer : Settings.ffi list, + effectful : Settings.ffi list, + benignEffectful : Settings.ffi list, + clientOnly : Settings.ffi list, + serverOnly : Settings.ffi list, + jsModule : string option, + jsFuncs : (Settings.ffi * string) list, + rewrites : Settings.rewrite list, + filterUrl : Settings.rule list, + filterMime : Settings.rule list, + filterRequest : Settings.rule list, + filterResponse : Settings.rule list, + filterEnv : Settings.rule list, + filterMeta : Settings.rule list, + protocol : string option, + dbms : string option, + sigFile : string option, + safeGets : string list, + onError : (string * string list * string) option, + minHeap : int +} + +type ('src, 'dst) phase = { + func : 'src -> 'dst, + print : 'dst -> Print.PD.pp_desc +} + +type pmap = (string * Time.time) list + +type ('src, 'dst) transform = { + func : 'src -> 'dst option, + print : 'dst -> Print.PD.pp_desc, + time : 'src * pmap -> 'dst option * pmap +} + +val debug = ref false +val dumpSource = ref false +val doIflow = ref false + +val doDumpSource = ref (fn () => ()) + +val stop = ref (NONE : string option) +fun setStop s = stop := SOME s + +fun transform (ph : ('src, 'dst) phase) name = { + func = fn input => let + val () = if !debug then + print ("Starting " ^ name ^ "....\n") + else + () + val v = #func ph input + in + if !debug then + print ("Finished " ^ name ^ ".\n") + else + (); + if ErrorMsg.anyErrors () then + (!doDumpSource (); + doDumpSource := (fn () => ()); + NONE) + else if !stop = SOME name then + (Print.eprint (#print ph v); + ErrorMsg.error ("Stopped compilation after phase " ^ name); + NONE) + else + (if !dumpSource then + doDumpSource := (fn () => Print.eprint (#print ph v)) + else + (); + SOME v) + end, + print = #print ph, + time = fn (input, pmap) => let + val () = if !debug then + print ("Starting " ^ name ^ "....\n") + else + () + val befor = Time.now () + val v = #func ph input + val elapsed = Time.- (Time.now (), befor) + in + if !debug then + print ("Finished " ^ name ^ ".\n") + else + (); + (if ErrorMsg.anyErrors () then + NONE + else + SOME v, + (name, elapsed) :: pmap) + end +} + +fun check (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); + ignore (#func tr x)) + +fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors (); + #func tr x) + +fun runPrint (tr : ('src, 'dst) transform) input = + (ErrorMsg.resetErrors (); + case #func tr input of + NONE => print "Failure\n" + | SOME v => + (print "Success\n"; + Print.print (#print tr v); + print "\n")) + +fun runPrintToFile (tr : ('src, 'dst) transform) input fname = + (ErrorMsg.resetErrors (); + case #func tr input of + NONE => print "Failure\n" + | SOME v => + let + val outf = TextIO.openOut fname + val str = Print.openOut {dst = outf, wid = 80} + in + print "Success\n"; + Print.fprint str (#print tr v); + Print.PD.PPS.closeStream str; + TextIO.closeOut outf + end) + +fun time (tr : ('src, 'dst) transform) input = + let + val (_, pmap) = #time tr (input, []) + in + app (fn (name, time) => + print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); + print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); + print "\n" + end + +fun timePrint (tr : ('src, 'dst) transform) input = + let + val (ro, pmap) = #time tr (input, []) + in + app (fn (name, time) => + print (name ^ ": " ^ LargeReal.toString (Time.toReal time) ^ "\n")) (rev pmap); + print ("TOTAL: " ^ LargeReal.toString (Time.toReal (foldl Time.+ Time.zeroTime (map #2 pmap))) ^ "\n"); + print "\n"; + case ro of + NONE => print "Failure\n" + | SOME v => + (print "Success\n"; + Print.print (#print tr v); + print "\n") + end + +fun runPrintCoreFuncs (tr : ('src, Core.file) transform) input = + (ErrorMsg.resetErrors (); + case #func tr input of + NONE => print "Failure\n" + | SOME file => + (print "Success\n"; + app (fn (d, _) => + case d of + Core.DVal (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t) + | Core.DValRec xts => app (fn (x, _, t, _, _) => Print.preface(x, CorePrint.p_con CoreEnv.empty t)) xts + | _ => ()) file)) + +val parseUrs = + {func = fn filename => let + val fname = OS.FileSys.tmpName () + val outf = TextIO.openOut fname + val () = TextIO.output (outf, "sig\n") + val inf = FileIO.txtOpenIn filename + fun loop () = + case TextIO.inputLine inf of + NONE => () + | SOME line => (TextIO.output (outf, line); + loop ()) + val () = loop () + val () = TextIO.closeIn inf + val () = TextIO.closeOut outf + + val () = (ErrorMsg.resetErrors (); + ErrorMsg.resetPositioning filename; + Lex.UserDeclarations.initialize ()) + val file = FileIO.txtOpenIn fname + fun get _ = TextIO.input file + fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s + val lexer = LrParser.Stream.streamify (Lex.makeLexer get) + val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) + in + TextIO.closeIn file; + case absyn of + [(Source.DSgn ("?", (Source.SgnConst sgis, _)), _)] => sgis + | _ => (ErrorMsg.errorAt {file = filename, + first = {line = 0, + char = 0}, + last = {line = 0, + char = 0}} "Not a signature"; + []) + end + handle LrParser.ParseError => [], + print = Print.p_list_sep Print.PD.newline SourcePrint.p_sgn_item} + +(* The main parsing routine *) +val parseUr = { + func = fn filename => + let + val () = (ErrorMsg.resetErrors (); + ErrorMsg.resetPositioning filename; + Lex.UserDeclarations.initialize ()) + val file = FileIO.txtOpenIn filename + fun get _ = TextIO.input file + fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s + val lexer = LrParser.Stream.streamify (Lex.makeLexer get) + val (absyn, _) = UrwebP.parse (30, lexer, parseerror, ()) + in + TextIO.closeIn file; + case absyn of + [(Source.DSgn ("?", _), _)] => + (ErrorMsg.errorAt {file = filename, + first = {line = 0, + char = 0}, + last = {line = 0, + char = 0}} "File starts with 'sig'"; + []) + | _ => absyn + end + handle LrParser.ParseError => [], + print = SourcePrint.p_file} + +fun p_job ({prefix, database, exe, sql, sources, debug, profile, + timeout, ffi, link, headers, scripts, + clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = + let + open Print.PD + open Print + + fun p_ffi name = p_list_sep (box []) (fn (m, s) => + box [string name, space, string m, string ".", string s, newline]) + in + box [if debug then + box [string "DEBUG", newline] + else + box [], + if profile then + box [string "PROFILE", newline] + else + box [], + case database of + NONE => string "No database." + | SOME db => string ("Database: " ^ db), + newline, + string "Exe: ", + string exe, + newline, + case sql of + NONE => string "No SQL file." + | SOME sql => string ("SQL fle: " ^ sql), + newline, + string "Timeout: ", + string (Int.toString timeout), + newline, + p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi, + p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers, + p_list_sep (box []) (fn s => box [string "Script", space, string s, newline]) scripts, + p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link, + p_ffi "ClientToServer" clientToServer, + p_ffi "Effectful" effectful, + p_ffi "BenignEffectful" benignEffectful, + p_ffi "ClientOnly" clientOnly, + p_ffi "ServerOnly" serverOnly, + case jsModule of + NONE => string "No JavaScript FFI module" + | SOME m => string ("JavaScript FFI module: " ^ m), + p_list_sep (box []) (fn ((m, s), s') => + box [string "JsFunc", space, string m, string ".", string s, + space, string "=", space, string s', newline]) jsFuncs, + string "Sources:", + p_list string sources, + newline] + end + +fun trim s = + let + val (_, s) = Substring.splitl Char.isSpace s + val (s, _) = Substring.splitr Char.isSpace s + in + s + end + +val trimS = Substring.string o trim o Substring.full + +structure M = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +(* XXX ezyang: pathmap gets initialized /really early/, before + * we do any options parsing. So libUr will always point to the + * default. We override it explicitly in enableBoot *) +val pathmap = ref (M.insert (M.empty, "", Settings.libUr ())) + +fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v) + +(* XXX ezyang: this is not right; it probably doesn't work in + * the case of separate build and src trees *) +fun enableBoot () = + (Settings.configBin := OS.Path.joinDirFile {dir = Config.builddir, file = "bin"}; + Settings.configSrcLib := OS.Path.joinDirFile {dir = Config.builddir, file = "lib"}; + (* joinDirFile is annoying... (ArcError; it doesn't like + * slashes in file) *) + Settings.configLib := Config.builddir ^ "/src/c/.libs"; + Settings.configInclude := OS.Path.joinDirFile {dir = Config.builddir ^ "/include", file = "urweb"}; + Settings.configSitelisp := Config.builddir ^ "/src/elisp"; + addPath ("", Settings.libUr ())) + +fun capitalize "" = "" + | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun institutionalizeJob (job : job) = + (Settings.setDebug (#debug job); + Settings.setUrlPrefix (#prefix job); + Settings.setTimeout (#timeout job); + Settings.setHeaders (#headers job); + Settings.setScripts (#scripts job); + Settings.setClientToServer (#clientToServer job); + Settings.setEffectful (#effectful job); + Settings.setBenignEffectful (#benignEffectful job); + Settings.setClientOnly (#clientOnly job); + Settings.setServerOnly (#serverOnly job); + Settings.setJsModule (#jsModule job); + Settings.setJsFuncs (#jsFuncs job); + Settings.setRewriteRules (#rewrites job); + Settings.setUrlRules (#filterUrl job); + Settings.setMimeRules (#filterMime job); + Settings.setRequestHeaderRules (#filterRequest job); + Settings.setResponseHeaderRules (#filterResponse job); + Settings.setEnvVarRules (#filterEnv job); + Settings.setMetaRules (#filterMeta job); + Option.app Settings.setProtocol (#protocol job); + Option.app Settings.setDbms (#dbms job); + Settings.setSafeGets (#safeGets job); + Settings.setOnError (#onError job); + Settings.setMinHeap (#minHeap job); + Settings.setSigFile (#sigFile job)) + +datatype commentableLine = + EndOfFile + | OnlyComment + | Content of string + +fun inputCommentableLine inf = + case TextIO.inputLine inf of + NONE => EndOfFile + | SOME s => + let + val (befor, after) = Substring.splitl (fn ch => ch <> #"#") (Substring.full s) + in + if not (Substring.isEmpty after) + andalso Substring.foldl (fn (ch, b) => b andalso Char.isSpace ch) true befor then + OnlyComment + else + let + val s = #1 (Substring.splitr (not o Char.isSpace) befor) + in + Content (Substring.string (if Substring.size s > 0 andalso Char.isSpace (Substring.sub (s, Substring.size s - 1)) then + if Substring.size s > 1 andalso Char.isSpace (Substring.sub (s, Substring.size s - 2)) then + Substring.trimr 2 s + else + Substring.trimr 1 s + else + s)) + end + end + +val lastUrp = ref "" + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) + +fun parseUrp' accLibs fname = + (lastUrp := fname; + if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) + andalso Posix.FileSys.access (fname ^ ".ur", []) then + let + val job = {prefix = "/", + database = NONE, + sources = [fname], + exe = fname ^ ".exe", + sql = NONE, + debug = Settings.getDebug (), + profile = false, + timeout = 120, + ffi = [], + link = [], + linker = NONE, + headers = [], + scripts = [], + clientToServer = [], + effectful = [], + benignEffectful = [], + clientOnly = [], + serverOnly = [], + jsModule = NONE, + jsFuncs = [], + rewrites = [{pkind = Settings.Any, + kind = Settings.Prefix, + from = capitalize (OS.Path.file fname) ^ "/", to = "", + hyphenate = false}], + filterUrl = [], + filterMime = [], + filterRequest = [], + filterResponse = [], + filterEnv = [], + filterMeta = [], + protocol = NONE, + dbms = NONE, + sigFile = NONE, + safeGets = [], + onError = NONE, + minHeap = 0} + in + institutionalizeJob job; + {Job = job, Libs = []} + end + else + let + val pathmap = ref (!pathmap) + val bigLibs = ref [] + val libSet = ref SS.empty + + fun pu filename = + let + val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()} + val thisPath = OS.Path.dir filename + + val dir = OS.Path.dir filename + fun opener () = FileIO.txtOpenIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) + + val inf = opener () + + fun hasSpaceLine () = + case inputCommentableLine inf of + Content s => s = "debug" orelse s = "profile" + orelse s = "html5" orelse s = "xhtml" + orelse s = "noMangleSql" orelse s = "lessSafeFfi" + orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine () + | EndOfFile => false + | OnlyComment => hasSpaceLine () + + val hasBlankLine = hasSpaceLine () + + val inf = (TextIO.closeIn inf; opener ()) + + fun pathify fname = + if size fname > 0 andalso String.sub (fname, 0) = #"$" then + let + val fname' = Substring.extract (fname, 1, NONE) + val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' + in + case M.find (!pathmap, Substring.string befor) of + NONE => fname + | SOME rep => rep ^ Substring.string after + end + else + fname + + fun relify fname = + let + val fname = pathify fname + in + OS.Path.concat (dir, fname) + handle OS.Path.Path => fname + end + + fun libify path = + (if Posix.FileSys.access (path ^ ".urp", []) then + path + else + path ^ "/lib") + handle SysErr => path + + fun libify' path = + (if Posix.FileSys.access (relify path ^ ".urp", []) then + path + else + path ^ "/lib") + handle SysErr => path + + val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} + + fun relifyA fname = + OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} + + fun readSources acc = + case inputCommentableLine inf of + Content line => + let + val acc = if CharVector.all Char.isSpace line then + acc + else + let + fun trim s = + let + val s = Substring.full s + val (_, s) = Substring.splitl Char.isSpace s + val (s, _) = Substring.splitr Char.isSpace s + in + Substring.string s + end + + val fname = relifyA (trim line) + in + fname :: acc + end + in + readSources acc + end + | OnlyComment => readSources acc + | EndOfFile => rev acc + + val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s) + val database = ref (Settings.getDbstring ()) + val exe = ref (Settings.getExe ()) + val sql = ref (Settings.getSql ()) + val debug = ref (Settings.getDebug ()) + val profile = ref false + val timeout = ref NONE + val ffi = ref [] + val link = ref [] + val linker = ref NONE + val headers = ref [] + val scripts = ref [] + val clientToServer = ref [] + val effectful = ref [] + val benignEffectful = ref [] + val clientOnly = ref [] + val serverOnly = ref [] + val jsModule = ref NONE + val jsFuncs = ref [] + val rewrites = ref [] + val url = ref [] + val mime = ref [] + val request = ref [] + val response = ref [] + val env = ref [] + val meta = ref [] + val libs = ref [] + val protocol = ref NONE + val dbms = ref NONE + val sigFile = ref (Settings.getSigFile ()) + val safeGets = ref [] + val onError = ref NONE + val minHeap = ref 0 + + fun finish sources = + let + val job = { + prefix = Option.getOpt (!prefix, "/"), + database = !database, + exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, + ext = SOME "exe"}), + sql = !sql, + debug = !debug, + profile = !profile, + timeout = Option.getOpt (!timeout, 60), + ffi = rev (!ffi), + link = rev (!link), + linker = !linker, + headers = rev (!headers), + scripts = rev (!scripts), + clientToServer = rev (!clientToServer), + effectful = rev (!effectful), + benignEffectful = rev (!benignEffectful), + clientOnly = rev (!clientOnly), + serverOnly = rev (!serverOnly), + jsModule = !jsModule, + jsFuncs = rev (!jsFuncs), + rewrites = rev (!rewrites), + filterUrl = rev (!url), + filterMime = rev (!mime), + filterRequest = rev (!request), + filterResponse = rev (!response), + filterEnv = rev (!env), + filterMeta = rev (!meta), + sources = sources, + protocol = !protocol, + dbms = !dbms, + sigFile = !sigFile, + safeGets = rev (!safeGets), + onError = !onError, + minHeap = !minHeap + } + + fun mergeO f (old, new) = + case (old, new) of + (NONE, _) => new + | (_, NONE) => old + | (SOME v1, SOME v2) => SOME (f (v1, v2)) + + fun same desc = mergeO (fn (x : string, y) => + (if x = y then + () + else + ErrorMsg.error ("Multiple " + ^ desc ^ " values that don't agree"); + x)) + + fun merge (old : job, new : job) = { + prefix = case #prefix old of + "/" => #prefix new + | pold => case #prefix new of + "/" => pold + | pnew => (if pold = pnew then + () + else + ErrorMsg.error ("Multiple prefix values that don't agree: " + ^ pold ^ ", " ^ pnew); + pold), + database = mergeO (fn (old, _) => old) (#database old, #database new), + exe = #exe old, + sql = #sql old, + debug = #debug old orelse #debug new, + profile = #profile old orelse #profile new, + timeout = #timeout old, + ffi = #ffi old @ #ffi new, + link = #link old @ #link new, + linker = mergeO (fn (_, new) => new) (#linker old, #linker new), + headers = #headers old @ #headers new, + scripts = #scripts old @ #scripts new, + clientToServer = #clientToServer old @ #clientToServer new, + effectful = #effectful old @ #effectful new, + benignEffectful = #benignEffectful old @ #benignEffectful new, + clientOnly = #clientOnly old @ #clientOnly new, + serverOnly = #serverOnly old @ #serverOnly new, + jsModule = #jsModule old, + jsFuncs = #jsFuncs old @ #jsFuncs new, + rewrites = #rewrites old @ #rewrites new, + filterUrl = #filterUrl old @ #filterUrl new, + filterMime = #filterMime old @ #filterMime new, + filterRequest = #filterRequest old @ #filterRequest new, + filterResponse = #filterResponse old @ #filterResponse new, + filterEnv = #filterEnv old @ #filterEnv new, + filterMeta = #filterMeta old @ #filterMeta new, + sources = #sources new + @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new)) + (#sources old), + protocol = mergeO #2 (#protocol old, #protocol new), + dbms = mergeO #2 (#dbms old, #dbms new), + sigFile = mergeO #2 (#sigFile old, #sigFile new), + safeGets = #safeGets old @ #safeGets new, + onError = mergeO #2 (#onError old, #onError new), + minHeap = Int.max (#minHeap old, #minHeap new) + } + in + if accLibs then + foldl (fn (job', job) => merge (job, job')) job (!libs) + else + job + end + + fun parsePkind s = + case s of + "all" => Settings.Any + | "url" => Settings.Url + | "table" => Settings.Table + | "sequence" => Settings.Sequence + | "view" => Settings.View + | "relation" => Settings.Relation + | "cookie" => Settings.Cookie + | "style" => Settings.Style + | _ => (ErrorMsg.error "Bad path kind spec"; + Settings.Any) + + fun parsePattern s = + if size s > 0 andalso String.sub (s, size s - 1) = #"*" then + (Settings.Prefix, String.substring (s, 0, size s - 1)) + else + (Settings.Exact, s) + + fun parseFkind s = + case s of + "url" => url + | "mime" => mime + | "requestHeader" => request + | "responseHeader" => response + | "env" => env + | "meta" => meta + | _ => (ErrorMsg.error "Bad filter kind"; + url) + + fun read () = + case inputCommentableLine inf of + EndOfFile => finish [] + | OnlyComment => read () + | Content "" => finish (readSources []) + | Content line => + let + val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) + val cmd = Substring.string (trim cmd) + val arg = Substring.string (trim arg) + + fun ffiS () = + case String.fields (fn ch => ch = #".") arg of + [m, x] => (m, x) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); + ("", "")) + + fun ffiM () = + case String.fields (fn ch => ch = #"=") arg of + [f, s] => + let + val f = trimS f + val s = trimS s + in + case String.fields (fn ch => ch = #".") f of + [m, x] => ((m, x), s) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), "")) + end + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), "")) + in + case cmd of + "prefix" => prefix := SOME arg + | "database" => + (case !database of + NONE => database := SOME arg + | SOME _ => ()) + | "dbms" => + (case !dbms of + NONE => dbms := SOME arg + | SOME _ => ()) + | "sigfile" => + (case !sigFile of + NONE => sigFile := SOME arg + | SOME _ => ()) + | "exe" => + (case !exe of + NONE => exe := SOME (relify arg) + | SOME _ => ()) + | "sql" => + (case !sql of + NONE => sql := SOME (relify arg) + | SOME _ => ()) + | "debug" => debug := true + | "profile" => profile := true + | "timeout" => + (case !timeout of + NONE => () + | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; + timeout := SOME (valOf (Int.fromString arg))) + | "ffi" => ffi := relify arg :: !ffi + | "link" => let + val arg = if size arg >= 1 + andalso String.sub (arg, 0) = #"-" then + arg + else + relifyA arg + in + link := arg :: !link + end + | "linker" => linker := SOME arg + | "include" => headers := relifyA arg :: !headers + | "script" => scripts := arg :: !scripts + | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "safeGet" => safeGets := arg :: !safeGets + | "effectful" => effectful := ffiS () :: !effectful + | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful + | "clientOnly" => clientOnly := ffiS () :: !clientOnly + | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsModule" => + (case !jsModule of + NONE => jsModule := SOME arg + | SOME _ => ()) + | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs + | "rewrite" => + let + fun doit (pkind, from, to, hyph) = + let + val pkind = parsePkind pkind + val (kind, from) = parsePattern from + in + rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites + end + in + case String.tokens Char.isSpace arg of + [pkind, from, to, "[-]"] => doit (pkind, from, to, true) + | [pkind, from, "[-]"] => doit (pkind, from, "", true) + | [pkind, from, to] => doit (pkind, from, to, false) + | [pkind, from] => doit (pkind, from, "", false) + | _ => ErrorMsg.error "Bad 'rewrite' syntax" + end + | "allow" => + (case String.tokens Char.isSpace arg of + [fkind, pattern] => + let + val fkind = parseFkind fkind + val (kind, pattern) = parsePattern pattern + in + fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind + end + | _ => ErrorMsg.error "Bad 'allow' syntax") + | "deny" => + (case String.tokens Char.isSpace arg of + [fkind, pattern] => + let + val fkind = parseFkind fkind + val (kind, pattern) = parsePattern pattern + in + fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind + end + | _ => ErrorMsg.error "Bad 'deny' syntax") + | "library" => + if accLibs then + let + val arg = libify (relify arg) + in + if SS.member (!libSet, arg) then + () + else + (libs := pu arg :: !libs; + libSet := SS.add (!libSet, arg)) + end + else + bigLibs := libify' arg :: !bigLibs + | "path" => + (case String.fields (fn ch => ch = #"=") arg of + [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir})) + handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument") + | _ => ErrorMsg.error "path argument not of the form name=value'") + | "onError" => + (case String.fields (fn ch => ch = #".") arg of + m1 :: (fs as _ :: _) => + onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) + | _ => ErrorMsg.error "invalid 'onError' argument") + | "limit" => + (case String.fields Char.isSpace arg of + [class, num] => + (case Int.fromString num of + NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'") + | SOME n => + if n < 0 then + ErrorMsg.error ("invalid limit number '" ^ num ^ "'") + else + Settings.addLimit (class, n)) + | _ => ErrorMsg.error "invalid 'limit' arguments") + | "minHeap" => + (case Int.fromString arg of + NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'") + | SOME n => minHeap := n) + | "coreInline" => + (case Int.fromString arg of + NONE => ErrorMsg.error ("invalid core inline level '" ^ arg ^ "'") + | SOME n => Settings.setCoreInline n) + | "monoInline" => + (case Int.fromString arg of + NONE => ErrorMsg.error ("invalid mono inline level '" ^ arg ^ "'") + | SOME n => Settings.setMonoInline n) + | "alwaysInline" => Settings.addAlwaysInline arg + | "neverInline" => Settings.addNeverInline arg + | "noXsrfProtection" => Settings.addNoXsrfProtection arg + | "timeFormat" => Settings.setTimeFormat arg + | "noMangleSql" => Settings.setMangleSql false + | "html5" => Settings.setIsHtml5 true + | "xhtml" => Settings.setIsHtml5 false + | "lessSafeFfi" => Settings.setLessSafeFfi true + + | "file" => + (case String.fields Char.isSpace arg of + [uri, fname] => (Settings.setFilePath thisPath; + Settings.addFile {Uri = uri, + LoadFromFilename = fname}; + url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url) + | _ => ErrorMsg.error "Bad 'file' arguments") + + | "jsFile" => + (Settings.setFilePath thisPath; + Settings.addJsFile arg) + + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); + read () + end + + val job = if hasBlankLine then + read () + else + finish (readSources []) + in + TextIO.closeIn inf; + institutionalizeJob job; + job + end + in + {Job = pu fname, Libs = !bigLibs} + end) + +fun p_job' {Job = j, Libs = _ : string list} = p_job j + +val parseUrp = { + func = #Job o parseUrp' true, + print = p_job +} + +val parseUrp' = { + func = parseUrp' false, + print = p_job' +} + +val toParseJob = transform parseUrp "parseJob" +val toParseJob' = transform parseUrp' "parseJob'" + +fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = { + func = fn input => case #func tr1 input of + NONE => NONE + | SOME v => #func tr2 v, + print = #print tr2, + time = fn (input, pmap) => let + val (ro, pmap) = #time tr1 (input, pmap) + in + case ro of + NONE => (NONE, pmap) + | SOME v => #time tr2 (v, pmap) + end +} + +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +val moduleRoots = ref ([] : (string * string) list) +fun addModuleRoot (k, v) = moduleRoots := + (OS.Path.mkAbsolute {path = k, + relativeTo = OS.FileSys.getDir ()}, + v) :: !moduleRoots + +exception MissingFile of string + +val parse = { + func = fn {database, sources = fnames, ffi, onError, ...} : job => + let + val mrs = !moduleRoots + + val anyErrors = ref false + fun checkErrors () = anyErrors := (!anyErrors orelse ErrorMsg.anyErrors ()) + fun nameOf fname = + let + val fname = OS.Path.file fname + val fst = if size fname = 0 then #"!" else String.sub (fname, 0) + in + if not (Char.isAlpha fst) then + ErrorMsg.error ("Filename doesn't start with letter: " ^ fname) + else if CharVector.exists (fn ch => not (Char.isAlphaNum ch) andalso ch <> #"_") fname then + ErrorMsg.error ("Filename contains a character that isn't alphanumeric or underscore: " ^ fname) + else + (); + capitalize fname + end + + fun parseFfi fname = + let + val mname = nameOf fname + val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} + + val loc = {file = urs, + first = ErrorMsg.dummyPos, + last = ErrorMsg.dummyPos} + + val sgn = (Source.SgnConst (#func parseUrs urs), loc) + in + checkErrors (); + (Source.DFfiStr (mname, sgn, if !Elaborate.incremental then SOME (OS.FileSys.modTime urs) else NONE), loc) + end + + val defed = ref SS.empty + val fulls = ref SS.empty + + val caughtOneThatIsn'tAFile = ref false + + fun parseOne fname = + let + val mname = nameOf fname + val ur = OS.Path.joinBaseExt {base = fname, ext = SOME "ur"} + val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"} + + val () = if Posix.FileSys.access (ur, []) then + () + else + raise MissingFile ur + + val sgnO = + if Posix.FileSys.access (urs, []) then + SOME (Source.SgnConst (#func parseUrs urs), + {file = urs, + first = ErrorMsg.dummyPos, + last = ErrorMsg.dummyPos}) + before checkErrors () + else + NONE + + val loc = {file = ur, + first = ErrorMsg.dummyPos, + last = ErrorMsg.dummyPos} + + val urt = OS.FileSys.modTime ur + val urst = (OS.FileSys.modTime urs) handle _ => urt + + val ds = #func parseUr ur + val d = (Source.DStr (mname, sgnO, if !Elaborate.incremental then SOME (if Time.> (urt, urst) then urt else urst) else NONE, + (Source.StrConst ds, loc), false), loc) + + val fname = OS.Path.mkCanonical fname + val d = case List.find (fn (root, name) => + String.isPrefix (root ^ "/") fname) mrs of + NONE => d + | SOME (root, name) => + let + val fname = String.extract (fname, size root + 1, NONE) + val pieces = name :: String.tokens (fn ch => ch = #"/") fname + val pieces = List.filter (fn s => size s > 0 + andalso Char.isAlpha (String.sub (s, 0))) + pieces + val pieces = map capitalize pieces + val full = String.concatWith "." pieces + + fun makeD first prefix pieces = + case pieces of + [] => (ErrorMsg.error "Empty module path"; + (Source.DStyle "Boo", loc)) + | [_] => d + | piece :: pieces => + let + val this = case prefix of + "" => piece + | _ => prefix ^ "." ^ piece + val old = SS.member (!defed, this) + + fun notThere (ch, s) = + Substring.isEmpty (#2 (Substring.splitl + (fn ch' => ch' <> ch) s)) + + fun simOpen () = + SS.foldl (fn (full, ds) => + if String.isPrefix (this ^ ".") full + andalso notThere (#".", + Substring.extract (full, + size + this + 1, + NONE)) then + let + val parts = String.tokens + (fn ch => ch = #".") full + + val part = List.last parts + + val imp = if length parts >= 2 then + (Source.StrProj + ((Source.StrVar + (List.nth (parts, + length + parts + - 2)), + loc), + part), loc) + else + (Source.StrVar part, loc) + in + (Source.DStr (part, NONE, NONE, imp, false), + loc) :: ds + end + else + ds) [] (!fulls) + in + defed := SS.add (!defed, this); + (Source.DStr (piece, NONE, NONE, + (Source.StrConst (if old then + simOpen () + @ [makeD false this pieces] + else + [makeD false this pieces]), + loc), first andalso old), + loc) + end + in + if SS.member (!fulls, full) then + ErrorMsg.error ("Rooted module " ^ full ^ " has multiple versions.") + else + (); + + makeD true "" pieces + before ignore (foldl (fn (new, path) => + let + val new' = case path of + "" => new + | _ => path ^ "." ^ new + in + fulls := SS.add (!fulls, new'); + new' + end) "" pieces) + end + in + checkErrors (); + d + end handle MissingFile fname => (if not (!caughtOneThatIsn'tAFile) + andalso CharVector.exists Char.isSpace fname then + (caughtOneThatIsn'tAFile := true; + ErrorMsg.error ("In .urp files, all configuration directives must come before any blank lines.\n" + ^ "However, this .urp file contains at least one suspicious line in a position\n" + ^ "where filenames belong (after the first blank line) but containing a space\n" + ^ "character.")) + else + (); + ErrorMsg.error ("Missing source file: " ^ fname); + (Source.DSequence "", ErrorMsg.dummySpan)) + + val dsFfi = map parseFfi ffi + val ds = map parseOne fnames + val loc = ErrorMsg.dummySpan + in + if !anyErrors then + ErrorMsg.error "Parse failure" + else + (); + + let + val final = List.last fnames + val final = case List.find (fn (root, name) => + String.isPrefix (root ^ "/") final) mrs of + NONE => (Source.StrVar (nameOf final), loc) + | SOME (root, name) => + let + val m = (Source.StrVar name, loc) + val final = String.extract (final, size root + 1, NONE) + val fields = String.fields (fn ch => ch = #"/") final + val fields = List.filter (fn s => size s = 0 + orelse not (Char.isDigit (String.sub (s, 0)))) + fields + in + foldl (fn (x, m) => (Source.StrProj (m, capitalize x), loc)) + m fields + end + + val ds = dsFfi @ ds + @ [(Source.DExport final, loc)] + + val ds = case database of + NONE => ds + | SOME s => (Source.DDatabase s, loc) :: ds + + val ds = case onError of + NONE => ds + | SOME v => ds @ [(Source.DOnError v, loc)] + + fun dummy fname = {file = Settings.libFile fname, + first = ErrorMsg.dummyPos, + last = ErrorMsg.dummyPos} + + val used = SM.insert (SM.empty, "Basis", dummy "basis.urs") + val used = SM.insert (used, "Top", dummy "top.urs") + in + ignore (List.foldl (fn (d, used) => + case #1 d of + Source.DStr (x, _, _, _, false) => + (case SM.find (used, x) of + SOME loc => + (ErrorMsg.error ("Duplicate top-level module name " ^ x); + Print.prefaces "Files" [("Previous", Print.PD.string (ErrorMsg.spanToString loc)), + ("Current", Print.PD.string (ErrorMsg.spanToString (#2 d)))]; + used) + | NONE => + SM.insert (used, x, #2 d)) + | _ => used) used ds); + ds + end handle Empty => ds + end, + print = SourcePrint.p_file +} + +val toParse = transform parse "parse" o toParseJob + +val elaborate = { + func = fn file => let + val basisF = Settings.libFile "basis.urs" + val topF = Settings.libFile "top.urs" + val topF' = Settings.libFile "top.ur" + + val basis = #func parseUrs basisF + val topSgn = #func parseUrs topF + val topStr = #func parseUr topF' + + val tm1 = OS.FileSys.modTime topF + val tm2 = OS.FileSys.modTime topF' + in + Elaborate.elabFile basis (OS.FileSys.modTime basisF) + topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1) + ElabEnv.empty file + end, + print = ElabPrint.p_file ElabEnv.empty +} + +val toElaborate = transform elaborate "elaborate" o toParse + +val unnest = { + func = Unnest.unnest, + print = ElabPrint.p_file ElabEnv.empty +} + +val toUnnest = transform unnest "unnest" o toElaborate + +val termination = { + func = (fn file => (Termination.check file; file)), + print = ElabPrint.p_file ElabEnv.empty +} + +val toTermination = transform termination "termination" o toUnnest + +val explify = { + func = Explify.explify, + print = ExplPrint.p_file ExplEnv.empty +} + +val toExplify = transform explify "explify" o toUnnest + +val corify = { + func = Corify.corify, + print = CorePrint.p_file CoreEnv.empty +} + +val toCorify = transform corify "corify" o toExplify + +(*val reduce_local = { + func = ReduceLocal.reduce, + print = CorePrint.p_file CoreEnv.empty +} + +val toReduce_local = transform reduce_local "reduce_local" o toCorify*) + +val especialize = { + func = ESpecialize.specialize, + print = CorePrint.p_file CoreEnv.empty +} + +val core_untangle = { + func = CoreUntangle.untangle, + print = CorePrint.p_file CoreEnv.empty +} + +val toCore_untangle = transform core_untangle "core_untangle" o toCorify + +val shake = { + func = Shake.shake, + print = CorePrint.p_file CoreEnv.empty +} + +val toShake1 = transform shake "shake1" o toCore_untangle + +val toEspecialize1' = transform especialize "especialize1'" o toShake1 +val toShake1' = transform shake "shake1'" o toEspecialize1' + +val rpcify = { + func = Rpcify.frob, + print = CorePrint.p_file CoreEnv.empty +} + +val toRpcify = transform rpcify "rpcify" o toShake1' + +val toCore_untangle2 = transform core_untangle "core_untangle2" o toRpcify +val toShake2 = transform shake "shake2" o toCore_untangle2 + +val toEspecialize1 = transform especialize "especialize1" o toShake2 + +val toCore_untangle3 = transform core_untangle "core_untangle3" o toEspecialize1 +val toShake3 = transform shake "shake3" o toCore_untangle3 + +val tag = { + func = Tag.tag, + print = CorePrint.p_file CoreEnv.empty +} + +val toTag = transform tag "tag" o toShake3 + +val reduce = { + func = Reduce.reduce, + print = CorePrint.p_file CoreEnv.empty +} + +val toReduce = transform reduce "reduce" o toTag + +val toShakey = transform shake "shakey" o toReduce + +val unpoly = { + func = Unpoly.unpoly, + print = CorePrint.p_file CoreEnv.empty +} + +val toUnpoly = transform unpoly "unpoly" o toShakey + +val specialize = { + func = Specialize.specialize, + print = CorePrint.p_file CoreEnv.empty +} + +val toSpecialize = transform specialize "specialize" o toUnpoly + +val toShake4 = transform shake "shake4" o toSpecialize + +val toEspecialize2 = transform especialize "especialize2" o toShake4 +val toShake4' = transform shake "shake4'" o toEspecialize2 +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 toReduce2 = transform reduce "reduce2" o toEspecialize3 + +val toShake5 = transform shake "shake5" o toReduce2 + +val marshalcheck = { + func = (fn file => (MarshalCheck.check file; file)), + print = CorePrint.p_file CoreEnv.empty +} + +val toMarshalcheck = transform marshalcheck "marshalcheck" o toShake5 + +val effectize = { + func = Effective.effectize, + print = CorePrint.p_file CoreEnv.empty +} + +val toEffectize = transform effectize "effectize" o toMarshalcheck + +val css = { + func = Css.summarize, + print = fn _ => Print.box [] +} + +val toCss = transform css "css" o toShake5 + +val monoize = { + func = Monoize.monoize CoreEnv.empty, + print = MonoPrint.p_file MonoEnv.empty +} + +val toMonoize = transform monoize "monoize" o toEffectize + +val mono_opt = { + func = MonoOpt.optimize, + print = MonoPrint.p_file MonoEnv.empty +} + +val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize + +val untangle = { + func = Untangle.untangle, + print = MonoPrint.p_file MonoEnv.empty +} + +val toUntangle = transform untangle "untangle" o toMono_opt1 + +val mono_reduce = { + func = MonoReduce.reduce, + print = MonoPrint.p_file MonoEnv.empty +} + +val toMono_reduce = transform mono_reduce "mono_reduce" o toUntangle + +val mono_shake = { + func = MonoShake.shake, + print = MonoPrint.p_file MonoEnv.empty +} + +val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce + +val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake + +val iflow = { + func = (fn file => (if !doIflow then Iflow.check file else (); file)), + print = MonoPrint.p_file MonoEnv.empty +} + +val toIflow = transform iflow "iflow" o toMono_opt2 + +val namejs = { + func = NameJS.rewrite, + print = MonoPrint.p_file MonoEnv.empty +} + +val toNamejs = transform namejs "namejs" o toIflow + +val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs + +val scriptcheck = { + func = ScriptCheck.classify, + print = MonoPrint.p_file MonoEnv.empty +} + +val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle + +val dbmodecheck = { + func = DbModeCheck.classify, + print = MonoPrint.p_file MonoEnv.empty +} + +val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck + +val jscomp = { + func = JsComp.process, + print = MonoPrint.p_file MonoEnv.empty +} + +val toJscomp = transform jscomp "jscomp" o toDbmodecheck + +val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp + +val fuse = { + func = Fuse.fuse, + print = MonoPrint.p_file MonoEnv.empty +} + +val toFuse = transform fuse "fuse" o toMono_opt3 + +val toUntangle2 = transform untangle "untangle2" o toFuse + +val toMono_reduce2 = transform mono_reduce "mono_reduce2" o toUntangle2 +val toMono_shake2 = transform mono_shake "mono_shake2" o toMono_reduce2 +val toMono_opt4 = transform mono_opt "mono_opt4" o toMono_shake2 +val toMono_reduce3 = transform mono_reduce "mono_reduce3" o toMono_opt4 +val toFuse2 = transform fuse "fuse2" o toMono_reduce3 +val toUntangle3 = transform untangle "untangle3" o toFuse2 +val toMono_shake3 = transform mono_shake "mono_shake3" o toUntangle3 + +val pathcheck = { + func = (fn file => (PathCheck.check file; file)), + print = MonoPrint.p_file MonoEnv.empty +} + +val toPathcheck = transform pathcheck "pathcheck" o toMono_shake3 + +val sidecheck = { + func = SideCheck.check, + print = MonoPrint.p_file MonoEnv.empty +} + +val toSidecheck = transform sidecheck "sidecheck" o toPathcheck + +val sigcheck = { + func = SigCheck.check, + print = MonoPrint.p_file MonoEnv.empty +} + +val toSigcheck = transform sigcheck "sigcheck" o toSidecheck + +val sqlcache = { + func = (fn file => + if Settings.getSqlcache () + then let val file = MonoInline.inlineFull file in Sqlcache.go file end + else file), + print = MonoPrint.p_file MonoEnv.empty +} + +val toSqlcache = transform sqlcache "sqlcache" o toSigcheck + +val cjrize = { + func = Cjrize.cjrize, + print = CjrPrint.p_file CjrEnv.empty +} + +val toCjrize = transform cjrize "cjrize" o toSqlcache + +val prepare = { + func = Prepare.prepare, + print = CjrPrint.p_file CjrEnv.empty +} + +val toPrepare = transform prepare "prepare" o toCjrize + +val checknest = { + func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f, + print = CjrPrint.p_file CjrEnv.empty +} + +val toChecknest = transform checknest "checknest" o toPrepare + +val sqlify = { + func = Cjrize.cjrize, + print = CjrPrint.p_sql CjrEnv.empty +} + +val toSqlify = transform sqlify "sqlify" o toMono_opt2 + +fun escapeFilename s = + "\"" + ^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s + ^ "\"" + +val beforeC = ref (fn () => ()) + +structure StringSet = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = + let + val proto = Settings.currentProtocol () + + val lib = if Settings.getBootLinking () then + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + else if Settings.getStaticLinking () then + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a" + else + "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" + + val opt = if debug then + "" + else + " -O3" + + val compile = (Settings.getCCompiler ()) ^ " " ^ Config.ccArgs ^ " " ^ Config.pthreadCflags ^ " -Wimplicit -Werror -Wno-unused-value" + ^ opt ^ " -I " ^ !Settings.configInclude + ^ " " ^ #compile proto + ^ " -c " ^ escapeFilename cname ^ " -o " ^ escapeFilename oname + + fun concatArgs (a1, a2) = + if CharVector.all Char.isSpace a1 then + a2 + else + a1 ^ " " ^ a2 + + val args = concatArgs (Config.ccArgs, Config.pthreadCflags) + val args = concatArgs (args, Config.pthreadLibs) + + val linker = Option.getOpt (linker, (Settings.getCCompiler ()) ^ " -Werror" ^ opt ^ " " ^ args) + + val ssl = if Settings.getStaticLinking () then + Config.openssl ^ " -ldl -lz" + else + Config.openssl + + val link = linker + ^ " " ^ escapeFilename oname ^ " " ^ lib ^ " -lm " ^ ssl ^ " " ^ libs ^ " -o " ^ escapeFilename ename + + val (compile, link) = + if profile then + (compile ^ " -pg", link ^ " -pg") + else + (compile, link) + + val (compile, link) = + if debug then + (compile ^ " -g", link ^ " -g") + else + (compile, link) + + val link = #1 (foldl + (fn (s, (link, set)) => + if StringSet.member (set, s) then + (link, set) + else + ((link ^ " " ^ s), StringSet.add (set, s))) + (link, StringSet.empty) + link') + + fun system s = + (if debug then + print (s ^ "\n") + else + (); + OS.Process.isSuccess (OS.Process.system s)) + in + !beforeC (); + system compile andalso system link + end + +fun compile job = + case run toChecknest job of + NONE => false + | SOME file => + let + val job = valOf (run (transform parseUrp "parseUrp") job) + + val (cname, oname, cleanup) = + if #debug job then + ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ()) + else + let + val dir = OS.FileSys.tmpName () + val () = if OS.FileSys.access (dir, []) then + OS.FileSys.remove dir + else + () + val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"} + val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"} + in + OS.FileSys.mkDir dir; + (cname, oname, + fn () => (if OS.Process.isSuccess (OS.Process.system ("rm -rf " ^ dir)) then + () + else + raise Fail ("Unable to delete temporary directory " ^ dir))) + end + val ename = #exe job + in + let + val outf = TextIO.openOut cname + val s = TextIOPP.openOut {dst = outf, wid = 80} + + val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file) + val libs = + if hasDb then + #link (Settings.currentDbms ()) + else + "" + in + Print.fprint s (CjrPrint.p_file CjrEnv.empty file); + TextIO.output1 (outf, #"\n"); + TextIO.closeOut outf; + + if ErrorMsg.anyErrors () then + false + else + (case #sql job of + NONE => () + | SOME sql => + let + val outf = TextIO.openOut sql + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (CjrPrint.p_sql CjrEnv.empty file); + 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} + + before cleanup ()) + end + handle ex => (((cleanup ()) handle _ => ()); raise ex) + end + +fun compiler job = + if compile job then + () + else + OS.Process.exit OS.Process.failure + +fun moduleOf fname = + let + val mrs = !moduleRoots + val fname = OS.Path.mkCanonical fname + in + case List.find (fn (root, _) => String.isPrefix (root ^ "/") fname) mrs of + NONE => capitalize (OS.Path.base (OS.Path.file fname)) + | SOME (root, name) => + let + val fname = OS.Path.base fname + val fname = String.extract (fname, size root + 1, NONE) + val fs = String.fields (fn ch => ch = #"/") fname + val fs = List.filter (CharVector.exists (fn ch => not (Char.isDigit ch))) fs + val fs = map capitalize fs + in + String.concatWith "." (name :: fs) + end + end + +end diff --git a/src/config.sig b/src/config.sig new file mode 100644 index 0000000..a3ad7d7 --- /dev/null +++ b/src/config.sig @@ -0,0 +1,23 @@ +signature CONFIG = sig + val builddir : string + + val bin : string + val srclib : string + val lib : string + val includ : string + val sitelisp : string + + val ccompiler : string + val ccArgs : string + val openssl : string + + val pgheader : string + val msheader : string + val sqheader : string + + val versionNumber : string + val versionString : string + + val pthreadCflags : string + val pthreadLibs : string +end diff --git a/src/config.sml.in b/src/config.sml.in new file mode 100644 index 0000000..ebcdb7b --- /dev/null +++ b/src/config.sml.in @@ -0,0 +1,37 @@ +structure Config :> CONFIG = struct + +val builddir = "@abs_top_builddir@" + +val bin = "@BIN@" +val srclib = "@SRCLIB@" +val lib = "@LIB@" +val includ = "@INCLUDE@" +val sitelisp = "@SITELISP@" + +val ccompiler = "@CC@" +val ccArgs = "@CCARGS@" + +val openssl = "@OPENSSL_LDFLAGS@ @OPENSSL_LIBS@" + +(* Something is rotten in the state of Ubuntu 11.10, so here's a manual fix that I hope doesn't break other platforms. *) +val openssl = + let + val tokens = String.tokens Char.isSpace openssl + in + if List.exists (fn s => s = "-lssl") tokens then + String.concatWith " " (List.filter (fn s => s <> "-lssl") tokens @ ["-lssl"]) + else + openssl + end + +val pgheader = "@PGHEADER@" +val msheader = "@MSHEADER@" +val sqheader = "@SQHEADER@" + +val versionNumber = "@VERSION@" +val versionString = "The Ur/Web compiler, version " ^ versionNumber + +val pthreadCflags = "@PTHREAD_CFLAGS@" +val pthreadLibs = "@PTHREAD_LIBS@" + +end diff --git a/src/coq/Axioms.v b/src/coq/Axioms.v new file mode 100644 index 0000000..0a0a84d --- /dev/null +++ b/src/coq/Axioms.v @@ -0,0 +1,47 @@ +(* Copyright (c) 2009, 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. + *) + +Set Implicit Arguments. + + +Axiom ext_eq : forall dom ran (f g : forall x : dom, ran x), + (forall x, f x = g x) + -> f = g. + +Theorem ext_eq_forall : forall dom (f g : forall x : dom, Type), + (forall x, f x = g x) + -> (forall x, f x) = (forall x, g x). + intros. + rewrite (ext_eq _ f g H); reflexivity. +Qed. + +Theorem ext_eq_forallS : forall dom (f g : forall x : dom, Set), + (forall x, f x = g x) + -> (forall x, f x) = (forall x, g x). + intros. + rewrite (ext_eq _ f g H); reflexivity. +Qed. diff --git a/src/coq/Makefile b/src/coq/Makefile new file mode 100644 index 0000000..fc488d6 --- /dev/null +++ b/src/coq/Makefile @@ -0,0 +1,14 @@ +MODULES := Axioms Name Syntax Semantics +VS := $(MODULES:%=%.v) + +.PHONY: coq clean + +coq: Makefile.coq + make -f Makefile.coq + +Makefile.coq: Makefile $(VS) + coq_makefile -impredicative-set $(VS) -o Makefile.coq + +clean:: Makefile.coq + make -f Makefile.coq clean + rm -f Makefile.coq diff --git a/src/coq/Name.v b/src/coq/Name.v new file mode 100644 index 0000000..6dedae6 --- /dev/null +++ b/src/coq/Name.v @@ -0,0 +1,31 @@ +(* Copyright (c) 2009, 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. + *) + +Require Import String. + +Definition name := string. +Definition name_eq_dec : forall x y : name, {x = y} + {x <> y} := string_dec. diff --git a/src/coq/README b/src/coq/README new file mode 100644 index 0000000..10cb01e --- /dev/null +++ b/src/coq/README @@ -0,0 +1,3 @@ +This is a Coq formalization of a simplified version of the Ur programming language. + +It has only been tested with Coq version 8.3pl2. diff --git a/src/coq/Semantics.v b/src/coq/Semantics.v new file mode 100644 index 0000000..c334a89 --- /dev/null +++ b/src/coq/Semantics.v @@ -0,0 +1,232 @@ +(* Copyright (c) 2009, 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +Require Import Eqdep_dec. + +Require Import Axioms. +Require Import Syntax. + +Set Implicit Arguments. + + +Definition row (A : Type) : Type := name -> option A. + +Definition record (r : row Set) := forall n, match r n with + | None => unit + | Some T => T + end. + +Fixpoint kDen (k : kind) : Type := + match k with + | KType => Set + | KName => name + | KArrow k1 k2 => kDen k1 -> kDen k2 + | KRecord k1 => row (kDen k1) + end. + +Definition disjoint T (r1 r2 : row T) := + forall n, match r1 n, r2 n with + | Some _, Some _ => False + | _, _ => True + end. + +Fixpoint cDen k (c : con kDen k) : kDen k := + match c with + | CVar _ x => x + | Arrow c1 c2 => cDen c1 -> cDen c2 + | Poly _ c1 => forall x, cDen (c1 x) + | CAbs _ _ c1 => fun x => cDen (c1 x) + | CApp _ _ c1 c2 => (cDen c1) (cDen c2) + | Name n => n + | TRecord c1 => record (cDen c1) + | CEmpty _ => fun _ => None + | CSingle _ c1 c2 => fun n => if name_eq_dec n (cDen c1) then Some (cDen c2) else None + | CConcat _ c1 c2 => fun n => match (cDen c1) n with + | None => (cDen c2) n + | v => v + end + | CMap k1 k2 => fun f r n => match r n with + | None => None + | Some T => Some (f T) + end + | TGuarded _ c1 c2 t => disjoint (cDen c1) (cDen c2) -> cDen t + end. + +Theorem subs_correct : forall k1 (c1 : con kDen k1) k2 (c2 : _ -> con kDen k2) c2', + subs c1 c2 c2' + -> cDen (c2 (cDen c1)) = cDen c2'. + induction 1; simpl; intuition; try (apply ext_eq_forallS || apply ext_eq); + repeat match goal with + | [ H : _ |- _ ] => rewrite H + end; intuition. +Qed. + +Definition dvar k (c1 c2 : con kDen (KRecord k)) := + disjoint (cDen c1) (cDen c2). + +Scheme deq_mut := Minimality for deq Sort Prop +with disj_mut := Minimality for disj Sort Prop. + +Ltac deq_disj_correct scm := + let t := repeat progress (simpl; intuition; subst) in + + let rec use_disjoint' notDone E := + match goal with + | [ H : disjoint _ _ |- _ ] => + notDone H; generalize (H E); use_disjoint' + ltac:(fun H' => + match H' with + | H => fail 1 + | _ => notDone H' + end) E + | _ => idtac + end in + let use_disjoint := use_disjoint' ltac:(fun _ => idtac) in + + apply (scm _ dvar + (fun k (c1 c2 : con kDen k) => + cDen c1 = cDen c2) + (fun k (c1 c2 : con kDen (KRecord k)) => + disjoint (cDen c1) (cDen c2))); t; + repeat ((unfold row; apply ext_eq) + || (match goal with + | [ H : _ |- _ ] => rewrite H; [] + | [ H : subs _ _ _ |- _ ] => rewrite <- (subs_correct H) + end); t); + unfold disjoint; t; + repeat (match goal with + | [ |- context[match cDen ?C ?E with Some _ => _ | None => _ end] ] => + use_disjoint E; destruct (cDen C E) + | [ |- context[if name_eq_dec ?N1 ?N2 then _ else _] ] => + use_disjoint N1; use_disjoint N2; destruct (name_eq_dec N1 N2) + | [ _ : context[match cDen ?C ?E with Some _ => _ | None => _ end] |- _ ] => + use_disjoint E; destruct (cDen C E) + | [ |- context[if ?E then _ else _] ] => destruct E + end; t). + +Hint Unfold dvar. + +Theorem deq_correct : forall k (c1 c2 : con kDen k), + deq dvar c1 c2 + -> cDen c1 = cDen c2. + deq_disj_correct deq_mut. +Qed. + +Theorem disj_correct : forall k (c1 c2 : con kDen (KRecord k)), + disj dvar c1 c2 + -> disjoint (cDen c1) (cDen c2). + deq_disj_correct disj_mut. +Qed. + +Definition tDen (t : con kDen KType) : Set := cDen t. + +Theorem name_eq_dec_refl : forall n, name_eq_dec n n = left _ (refl_equal n). + intros; destruct (name_eq_dec n n); intuition; [ + match goal with + | [ e : _ = _ |- _ ] => rewrite (UIP_dec name_eq_dec e (refl_equal _)); reflexivity + end + | elimtype False; tauto + ]. +Qed. + +Theorem cut_disjoint : forall n1 v r, + disjoint (fun n => if name_eq_dec n n1 then Some v else None) r + -> unit = match r n1 with + | Some T => T + | None => unit + end. + intros; + match goal with + | [ H : disjoint _ _ |- _ ] => generalize (H n1) + end; rewrite name_eq_dec_refl; + destruct (r n1); intuition. +Qed. + +Implicit Arguments cut_disjoint [v r]. + +Fixpoint eDen t (e : exp dvar tDen t) : tDen t := + match e in exp _ _ t return tDen t with + | Var _ x => x + | App _ _ e1 e2 => (eDen e1) (eDen e2) + | Abs _ _ e1 => fun x => eDen (e1 x) + | ECApp _ c _ _ e1 Hsub => match subs_correct Hsub in _ = T return T with + | refl_equal => (eDen e1) (cDen c) + end + | ECAbs _ _ e1 => fun X => eDen (e1 X) + | Cast _ _ Heq e1 => match deq_correct Heq in _ = T return T with + | refl_equal => eDen e1 + end + | Empty => fun _ => tt + | Single c c' e1 => fun n => if name_eq_dec n (cDen c) as B + return (match (match (if B then _ else _) with Some _ => _ | None => _ end) + with Some _ => _ | None => unit end) + then eDen e1 else tt + | Proj c _ _ e1 => + match name_eq_dec_refl (cDen c) in _ = B + return (match (match (if B then _ else _) with + | Some _ => _ + | None => _ end) + return Set + with Some _ => _ | None => _ end) with + | refl_equal => (eDen e1) (cDen c) + end + | Cut c _ c' Hdisj e1 => fun n => + match name_eq_dec n (cDen c) as B return (match (match (if B then Some _ else None) with Some _ => _ | None => (cDen c') n end) + with Some T => T | None => unit end + -> match (cDen c') n with + | None => unit + | Some T => T + end) with + | left Heq => fun _ => + match sym_eq Heq in _ = n' return match cDen c' n' return Set with Some _ => _ | None => _ end with + | refl_equal => + match cut_disjoint _ (disj_correct Hdisj) in _ = T return T with + | refl_equal => tt + end + end + | right _ => fun x => x + end ((eDen e1) n) + + | Concat c1 c2 e1 e2 => fun n => + match (cDen c1) n as D return match D with + | None => unit + | Some T => T + end + -> match (match D with + | None => (cDen c2) n + | Some v => Some v + end) with + | None => unit + | Some T => T + end with + | None => fun _ => (eDen e2) n + | _ => fun x => x + end ((eDen e1) n) + + | Guarded _ _ _ _ e1 => fun pf => eDen (e1 pf) + | GuardedApp _ _ _ _ e1 Hdisj => (eDen e1) (disj_correct Hdisj) + end. diff --git a/src/coq/Syntax.v b/src/coq/Syntax.v new file mode 100644 index 0000000..03f8d82 --- /dev/null +++ b/src/coq/Syntax.v @@ -0,0 +1,186 @@ +(* Copyright (c) 2009, 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. + *) + +Require Import Name. +Export Name. + +Set Implicit Arguments. + + +(** Syntax of Featherweight Ur *) + +Inductive kind : Type := +| KType : kind +| KName : kind +| KArrow : kind -> kind -> kind +| KRecord : kind -> kind. + +Section vars. + Variable cvar : kind -> Type. + + Inductive con : kind -> Type := + | CVar : forall k, cvar k -> con k + | Arrow : con KType -> con KType -> con KType + | Poly : forall k, (cvar k -> con KType) -> con KType + | CAbs : forall k1 k2, (cvar k1 -> con k2) -> con (KArrow k1 k2) + | CApp : forall k1 k2, con (KArrow k1 k2) -> con k1 -> con k2 + | Name : name -> con KName + | TRecord : con (KRecord KType) -> con KType + | CEmpty : forall k, con (KRecord k) + | CSingle : forall k, con KName -> con k -> con (KRecord k) + | CConcat : forall k, con (KRecord k) -> con (KRecord k) -> con (KRecord k) + | CMap : forall k1 k2, con (KArrow (KArrow k1 k2) (KArrow (KRecord k1) (KRecord k2))) + | TGuarded : forall k, con (KRecord k) -> con (KRecord k) -> con KType -> con KType. + + Variable dvar : forall k, con (KRecord k) -> con (KRecord k) -> Type. + + Section subs. + Variable k1 : kind. + Variable c1 : con k1. + + Inductive subs : forall k2, (cvar k1 -> con k2) -> con k2 -> Type := + | S_Unchanged : forall k2 (c2 : con k2), + subs (fun _ => c2) c2 + | S_CVar : subs (fun x => CVar x) c1 + | S_Arrow : forall c2 c3 c2' c3', + subs c2 c2' + -> subs c3 c3' + -> subs (fun x => Arrow (c2 x) (c3 x)) (Arrow c2' c3') + | S_Poly : forall k (c2 : cvar k1 -> cvar k -> _) (c2' : cvar k -> _), + (forall x', subs (fun x => c2 x x') (c2' x')) + -> subs (fun x => Poly (c2 x)) (Poly c2') + | S_CAbs : forall k2 k3 (c2 : cvar k1 -> cvar k2 -> con k3) (c2' : cvar k2 -> _), + (forall x', subs (fun x => c2 x x') (c2' x')) + -> subs (fun x => CAbs (c2 x)) (CAbs c2') + | S_CApp : forall k1 k2 (c2 : _ -> con (KArrow k1 k2)) c3 c2' c3', + subs c2 c2' + -> subs c3 c3' + -> subs (fun x => CApp (c2 x) (c3 x)) (CApp c2' c3') + | S_TRecord : forall c2 c2', + subs c2 c2' + -> subs (fun x => TRecord (c2 x)) (TRecord c2') + | S_CSingle : forall k2 c2 (c3 : _ -> con k2) c2' c3', + subs c2 c2' + -> subs c3 c3' + -> subs (fun x => CSingle (c2 x) (c3 x)) (CSingle c2' c3') + | S_CConcat : forall k2 (c2 c3 : _ -> con (KRecord k2)) c2' c3', + subs c2 c2' + -> subs c3 c3' + -> subs (fun x => CConcat (c2 x) (c3 x)) (CConcat c2' c3') + | S_TGuarded : forall k2 (c2 c3 : _ -> con (KRecord k2)) c4 c2' c3' c4', + subs c2 c2' + -> subs c3 c3' + -> subs c4 c4' + -> subs (fun x => TGuarded (c2 x) (c3 x) (c4 x)) (TGuarded c2' c3' c4'). + End subs. + + Inductive disj : forall k, con (KRecord k) -> con (KRecord k) -> Prop := + | DVar : forall k (c1 c2 : con (KRecord k)), + dvar c1 c2 -> disj c1 c2 + | DComm : forall k (c1 c2 : con (KRecord k)), + disj c1 c2 -> disj c2 c1 + + | DEmpty : forall k c2, + disj (CEmpty k) c2 + | DSingleKeys : forall k X1 X2 (c1 c2 : con k), + X1 <> X2 + -> disj (CSingle (Name X1) c1) (CSingle (Name X2) c2) + | DSingleValues : forall k n1 n2 (c1 c2 : con k) k' (c1' c2' : con k'), + disj (CSingle n1 c1') (CSingle n2 c2') + -> disj (CSingle n1 c1) (CSingle n2 c2) + + | DConcat : forall k (c1 c2 c : con (KRecord k)), + disj c1 c + -> disj c2 c + -> disj (CConcat c1 c2) c + + | DEq : forall k (c1 c2 c1' : con (KRecord k)), + disj c1 c2 + -> deq c1' c1 + -> disj c1' c2 + + with deq : forall k, con k -> con k -> Prop := + | Eq_Beta : forall k1 k2 (c1 : cvar k1 -> con k2) c2 c1', + subs c2 c1 c1' + -> deq (CApp (CAbs c1) c2) c1' + | Eq_Refl : forall k (c : con k), + deq c c + | Eq_Comm : forall k (c1 c2 : con k), + deq c2 c1 + -> deq c1 c2 + | Eq_Trans : forall k (c1 c2 c3 : con k), + deq c1 c2 + -> deq c2 c3 + -> deq c1 c3 + | Eq_Cong : forall k1 k2 c1 c1' (c2 : cvar k1 -> con k2) c2' c2'', + deq c1 c1' + -> subs c1 c2 c2' + -> subs c1' c2 c2'' + -> deq c2' c2'' + + | Eq_Concat_Empty : forall k c, + deq (CConcat (CEmpty k) c) c + | Eq_Concat_Comm : forall k (c1 c2 c3 : con (KRecord k)), + disj c1 c2 + -> deq (CConcat c1 c2) (CConcat c2 c1) + | Eq_Concat_Assoc : forall k (c1 c2 c3 : con (KRecord k)), + deq (CConcat c1 (CConcat c2 c3)) (CConcat (CConcat c1 c2) c3) + + | Eq_Map_Empty : forall k1 k2 f, + deq (CApp (CApp (CMap k1 k2) f) (CEmpty _)) (CEmpty _) + | Eq_Map_Cons : forall k1 k2 f c1 c2 c3, + disj (CSingle c1 c2) c3 + -> deq (CApp (CApp (CMap k1 k2) f) (CConcat (CSingle c1 c2) c3)) + (CConcat (CSingle c1 (CApp f c2)) (CApp (CApp (CMap k1 k2) f) c3)) + + | Eq_Map_Ident : forall k c, + deq (CApp (CApp (CMap k k) (CAbs (fun x => CVar x))) c) c + | Eq_Map_Dist : forall k1 k2 f c1 c2, + deq (CApp (CApp (CMap k1 k2) f) (CConcat c1 c2)) + (CConcat (CApp (CApp (CMap k1 k2) f) c1) (CApp (CApp (CMap k1 k2) f) c2)) + | Eq_Map_Fuse : forall k1 k2 k3 f f' c, + deq (CApp (CApp (CMap k2 k3) f') + (CApp (CApp (CMap k1 k2) f) c)) + (CApp (CApp (CMap k1 k3) (CAbs (fun x => CApp f' (CApp f (CVar x))))) c). + + Variable evar : con KType -> Type. + + Inductive exp : con KType -> Type := + | Var : forall t, evar t -> exp t + | App : forall dom ran, exp (Arrow dom ran) -> exp dom -> exp ran + | Abs : forall dom ran, (evar dom -> exp ran) -> exp (Arrow dom ran) + | ECApp : forall k (dom : con k) ran ran', exp (Poly ran) -> subs dom ran ran' -> exp ran' + | ECAbs : forall k (ran : cvar k -> _), (forall X, exp (ran X)) -> exp (Poly ran) + | Cast : forall t1 t2, deq t1 t2 -> exp t1 -> exp t2 + | Empty : exp (TRecord (CEmpty _)) + | Single : forall c t, exp t -> exp (TRecord (CConcat (CSingle c t) (CEmpty _))) + | Proj : forall c t c', exp (TRecord (CConcat (CSingle c t) c')) -> exp t + | Cut : forall c t c', disj (CSingle c t) c' -> exp (TRecord (CConcat (CSingle c t) c')) -> exp (TRecord c') + | Concat : forall c1 c2, exp (TRecord c1) -> exp (TRecord c2) -> exp (TRecord (CConcat c1 c2)) + | Guarded : forall k (c1 c2 : con (KRecord k)) c, (dvar c1 c2 -> exp c) -> exp (TGuarded c1 c2 c) + | GuardedApp : forall k (c1 c2 : con (KRecord k)) t, exp (TGuarded c1 c2 t) -> disj c1 c2 -> exp t. +End vars. diff --git a/src/core.sml b/src/core.sml new file mode 100644 index 0000000..8f57c31 --- /dev/null +++ b/src/core.sml @@ -0,0 +1,146 @@ +(* Copyright (c) 2008, 2013, 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 Core = struct + +type 'a located = 'a ErrorMsg.located + +datatype kind' = + KType + | KArrow of kind * kind + | KName + | KRecord of kind + | KUnit + | KTuple of kind list + + | KRel of int + | KFun of string * kind + +withtype kind = kind' located + +datatype con' = + TFun of con * con + | TCFun of string * kind * con + | TRecord of con + + | CRel of int + | CNamed of int + | CFfi of string * string + | CApp of con * con + | CAbs of string * kind * con + + | CKAbs of string * con + | CKApp of con * kind + | TKFun of string * con + + | CName of string + + | CRecord of kind * (con * con) list + | CConcat of con * con + | CMap of kind * kind + + | CUnit + + | CTuple of con list + | CProj of con * int + +withtype con = con' located + +datatype datatype_kind = datatype DatatypeKind.datatype_kind + +datatype patCon = + PConVar of int + | PConFfi of {mod : string, datatyp : string, params : string list, + con : string, arg : con option, kind : datatype_kind} + +datatype pat' = + PVar of string * con + | PPrim of Prim.t + | PCon of datatype_kind * patCon * con list * pat option + | PRecord of (string * pat * con) list + +withtype pat = pat' located + +datatype failure_mode = datatype Settings.failure_mode + +datatype exp' = + EPrim of Prim.t + | ERel of int + | ENamed of int + | ECon of datatype_kind * patCon * con list * exp option + | EFfi of string * string + | EFfiApp of string * string * (exp * con) list + | EApp of exp * exp + | EAbs of string * con * con * exp + | ECApp of exp * con + | ECAbs of string * kind * exp + + | EKAbs of string * exp + | EKApp of exp * kind + + | ERecord of (con * exp * con) list + | EField of exp * con * { field : con, rest : con } + | EConcat of exp * con * exp * con + | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } + + | ECase of exp * (pat * exp) list * { disc : con, result : con } + + | EWrite of exp + + | EClosure of int * exp list + + | ELet of string * con * exp * exp + + | EServerCall of int * exp list * con * failure_mode + +withtype exp = exp' located + +datatype effect = datatype Export.effect +datatype export_kind = datatype Export.export_kind + +datatype decl' = + DCon of string * int * kind * con + | DDatatype of (string * int * string list * (string * int * con option) list) list + | DVal of string * int * con * exp * string + | DValRec of (string * int * con * exp * string) list + | DExport of export_kind * int * bool + | DTable of string * int * con * string * exp * con * exp * con + | DSequence of string * int * string + | DView of string * int * string * exp * con + | DDatabase of string + | DCookie of string * int * con * string + | DStyle of string * int * string + | DTask of exp * exp + | DPolicy of exp + | DOnError of int + +withtype decl = decl' located + +type file = decl list + +end diff --git a/src/core_env.sig b/src/core_env.sig new file mode 100644 index 0000000..9377373 --- /dev/null +++ b/src/core_env.sig @@ -0,0 +1,72 @@ +(* Copyright (c) 2008, 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 CORE_ENV = sig + + val liftConInCon : int -> Core.con -> Core.con + val subConInCon : (int * Core.con) -> Core.con -> Core.con + + val liftConInExp : int -> Core.exp -> Core.exp + val subConInExp : (int * Core.con) -> Core.exp -> Core.exp + + val liftExpInExp : int -> Core.exp -> Core.exp + val subExpInExp : (int * Core.exp) -> Core.exp -> Core.exp + + type env + + val empty : env + + exception UnboundRel of int + exception UnboundNamed of int + + val pushKRel : env -> string -> env + val lookupKRel : env -> int -> string + + val pushCRel : env -> string -> Core.kind -> env + val lookupCRel : env -> int -> string * Core.kind + + val pushCNamed : env -> string -> int -> Core.kind -> Core.con option -> env + val lookupCNamed : env -> int -> string * Core.kind * Core.con option + + val pushDatatype : env -> string -> int -> string list -> (string * int * Core.con option) list -> env + val lookupDatatype : env -> int -> string * string list * (string * int * Core.con option) list + + val lookupConstructor : env -> int -> string * string list * Core.con option * int + + val pushERel : env -> string -> Core.con -> env + val lookupERel : env -> int -> string * Core.con + + val pushENamed : env -> string -> int -> Core.con -> Core.exp option -> string -> env + val lookupENamed : env -> int -> string * Core.con * Core.exp option * string + + val declBinds : env -> Core.decl -> env + val patBinds : env -> Core.pat -> env + + val patBindsN : Core.pat -> int + val patBindsL : Core.pat -> (string * Core.con) list + +end diff --git a/src/core_env.sml b/src/core_env.sml new file mode 100644 index 0000000..7d78bde --- /dev/null +++ b/src/core_env.sml @@ -0,0 +1,379 @@ +(* Copyright (c) 2008, 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 CoreEnv :> CORE_ENV = struct + +open Core + +structure U = CoreUtil + +structure IM = IntBinaryMap + + +(* AST utility functions *) + +val liftKindInKind = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + bind = fn (bound, _) => bound + 1} + +val liftKindInCon = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + +val liftKindInExp = + U.Exp.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelK _) => bound + 1 + | (bound, _) => bound} + +val liftConInCon = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} + +val lift = liftConInCon 0 + +val subConInCon = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn (xn, rep) => fn c => + case c of + CRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER => CRel (xn' - 1) + | LESS => c) + | _ => c, + bind = fn ((xn, rep), U.Con.RelC _) => (xn+1, liftConInCon 0 rep) + | (ctx, _) => ctx} + + +val liftConInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | _ => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelC _) => bound + 1 + | (bound, _) => bound} + +val subConInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn (xn, rep) => fn c => + case c of + CRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER => CRel (xn' - 1) + | LESS => c) + | _ => c, + exp = fn _ => fn e => e, + bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep) + | (ctx, _) => ctx} + +val liftExpInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + +(* Back to environments *) + +exception UnboundRel of int +exception UnboundNamed of int + +type env = { + relK : string list, + + relC : (string * kind) list, + namedC : (string * kind * con option) IM.map, + + datatypes : (string * string list * (string * int * con option) list) IM.map, + constructors : (string * string list * con option * int) IM.map, + + relE : (string * con) list, + namedE : (string * con * exp option * string) IM.map +} + +val empty = { + relK = [], + + relC = [], + namedC = IM.empty, + + datatypes = IM.empty, + constructors = IM.empty, + + relE = [], + namedE = IM.empty +} + +fun pushKRel (env : env) x = + {relK = x :: #relK env, + + relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env), + namedC = #namedC env, + + relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env), + namedE = #namedE env, + + datatypes = #datatypes env, + constructors = #constructors env + } + +fun lookupKRel (env : env) n = + (List.nth (#relK env, n)) + handle Subscript => raise UnboundRel n + +fun pushCRel (env : env) x k = + {relK = #relK env, + + relC = (x, k) :: #relC env, + namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), + + datatypes = #datatypes env, + constructors = #constructors env, + + relE = map (fn (x, c) => (x, lift c)) (#relE env), + namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)} + +fun lookupCRel (env : env) n = + (List.nth (#relC env, n)) + handle Subscript => raise UnboundRel n + +fun pushCNamed (env : env) x n k co = + {relK = #relK env, + + relC = #relC env, + namedC = IM.insert (#namedC env, n, (x, k, co)), + + datatypes = #datatypes env, + constructors = #constructors env, + + relE = #relE env, + namedE = #namedE env} + +fun lookupCNamed (env : env) n = + case IM.find (#namedC env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushDatatype (env : env) x n xs xncs = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + datatypes = IM.insert (#datatypes env, n, (x, xs, xncs)), + constructors = foldl (fn ((x, n', to), constructors) => + IM.insert (constructors, n', (x, xs, to, n))) + (#constructors env) xncs, + + relE = #relE env, + namedE = #namedE env} + +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupConstructor (env : env) n = + case IM.find (#constructors env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushERel (env : env) x t = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + relE = (x, t) :: #relE env, + namedE = #namedE env} + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun pushENamed (env : env) x n t eo s = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t, eo, s))} + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun declBinds env (d, loc) = + case d of + DCon (x, n, k, c) => pushCNamed env x n k (SOME c) + | DDatatype dts => + foldl (fn ((x, n, xs, xncs), env) => + let + val env = pushDatatype env x n xs xncs + val env = pushCNamed env x n (KType, loc) NONE + in + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (CNamed n, loc) NONE "" + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (CNamed n, loc)), loc) NONE "") + env xncs + end) env dts + | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s + | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis + | DExport _ => env + | DTable (x, n, c, s, _, pc, _, cc) => + let + val ct = (CFfi ("Basis", "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + pushENamed env x n ct NONE s + end + | DSequence (x, n, s) => + let + val t = (CFfi ("Basis", "sql_sequence"), loc) + in + pushENamed env x n t NONE s + end + | DView (x, n, s, _, c) => + let + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct NONE s + end + | DDatabase _ => env + | DCookie (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "http_cookie"), loc), c), loc) + in + pushENamed env x n t NONE s + end + | DStyle (x, n, s) => + let + val t = (CFfi ("Basis", "css_class"), loc) + in + pushENamed env x n t NONE s + end + | DTask _ => env + | DPolicy _ => env + | DOnError _ => env + +fun patBinds env (p, loc) = + case p of + PVar (x, t) => pushERel env x t + | PPrim _ => env + | PCon (_, _, _, NONE) => env + | PCon (_, _, _, SOME p) => patBinds env p + | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps + +fun patBindsN (p, loc) = + case p of + PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + +fun patBindsL (p, loc) = + case p of + PVar (x, t) => [(x, t)] + | PPrim _ => [] + | PCon (_, _, _, NONE) => [] + | PCon (_, _, _, SOME p) => patBindsL p + | PRecord xps => rev (ListUtil.mapConcat (rev o patBindsL o #2) xps) + +end diff --git a/src/core_print.sig b/src/core_print.sig new file mode 100644 index 0000000..aee3717 --- /dev/null +++ b/src/core_print.sig @@ -0,0 +1,41 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web internal language *) + +signature CORE_PRINT = sig + val p_kind : CoreEnv.env -> Core.kind Print.printer + val p_con : CoreEnv.env -> Core.con Print.printer + val p_patCon : CoreEnv.env -> Core.patCon Print.printer + val p_pat : CoreEnv.env -> Core.pat Print.printer + val p_exp : CoreEnv.env -> Core.exp Print.printer + val p_decl : CoreEnv.env -> Core.decl Print.printer + val p_file : CoreEnv.env -> Core.file Print.printer + + val debug : bool ref +end + diff --git a/src/core_print.sml b/src/core_print.sml new file mode 100644 index 0000000..5c71e97 --- /dev/null +++ b/src/core_print.sml @@ -0,0 +1,643 @@ +(* Copyright (c) 2008-2011, 2013, 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. + *) + +(* Pretty-printing core Ur/Web *) + +structure CorePrint :> CORE_PRINT = struct + +open Print.PD +open Print + +open Core + +structure E = CoreEnv + +val debug = ref false + +fun p_kind' par env (k, _) = + case k of + KType => string "Type" + | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, + space, + string "->", + space, + p_kind env k2]) + | KName => string "Name" + | KRecord k => box [string "{", p_kind env k, string "}"] + | KUnit => string "Unit" + | KTuple ks => box [string "(", + p_list_sep (box [space, string "*", space]) (p_kind env) ks, + string ")"] + + | KRel n => ((if !debug then + string (E.lookupKRel env n ^ "_" ^ Int.toString n) + else + string (E.lookupKRel env n)) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind (E.pushKRel env x) k] + +and p_kind env = p_kind' false env + +fun p_con' par env (c, _) = + case c of + TFun (t1, t2) => parenIf par (box [p_con' true env t1, + space, + string "->", + space, + p_con env t2]) + | TCFun (x, k, c) => parenIf par (box [string x, + space, + string "::", + space, + p_kind env k, + space, + string "->", + space, + p_con (E.pushCRel env x k) c]) + | TRecord (CRecord (_, xcs), _) => box [string "{", + p_list (fn (x, c) => + box [p_name env x, + space, + string ":", + space, + p_con env c]) xcs, + string "}"] + | TRecord c => box [string "$", + p_con' true env c] + + | CRel n => + ((if !debug then + string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupCRel env n))) + handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) + | CNamed n => + ((if !debug then + string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupCNamed env n))) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) + | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] + + | CApp (c1, c2) => parenIf par (box [p_con env c1, + space, + p_con' true env c2]) + | CAbs (x, k, c) => parenIf par (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind env k, + space, + string "=>", + space, + p_con (E.pushCRel env x k) c]) + + | CName s => box [string "#", string s] + + | CRecord (k, xcs) => + if !debug then + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_con env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]::", + p_kind env k]) + else + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_con env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]"]) + | CConcat (c1, c2) => parenIf par (box [p_con' true env c1, + space, + string "++", + space, + p_con env c2]) + | CMap _ => string "map" + | CUnit => string "()" + + | CTuple cs => box [string "(", + p_list (p_con env) cs, + string ")"] + | CProj (c, n) => box [p_con env c, + string ".", + string (Int.toString n)] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con (E.pushKRel env x) c] + | CKApp (c, k) => box [p_con env c, + string "[[", + p_kind env k, + string "]]"] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con (E.pushKRel env x) c] + +and p_con env = p_con' false env + +and p_name env (all as (c, _)) = + case c of + CName s => string s + | _ => p_con env all + +fun p_enamed env n = + (if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n) + +fun p_con_named env n = + (if !debug then + string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupConstructor env n))) + handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n) + +fun p_patCon env pc = + case pc of + PConVar n => p_con_named env n + | PConFfi {mod = m, con, arg, params, ...} => + if !debug then + box [string "FFIC[", + case arg of + NONE => box [] + | SOME t => + let + val k = (KType, ErrorMsg.dummySpan) + val env' = foldl (fn (x, env) => E.pushCRel env x k) env params + in + p_con env' t + end, + string "](", + string m, + string ".", + string con, + string ")"] + else + box [string "FFIC(", + string m, + string ".", + string con, + string ")"] + +fun p_pat' par env (p, _) = + case p of + PVar (s, _) => string s + | PPrim p => Prim.p_t p + | PCon (_, n, _, NONE) => p_patCon env n + | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n, + space, + p_pat' true env p]) + | PRecord xps => + box [string "{", + p_list_sep (box [string ",", space]) (fn (x, p, t) => + box [string x, + space, + string "=", + space, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, + string "}"] + +and p_pat x = p_pat' false x + +fun p_exp' par env (e, _) = + case e of + EPrim p => Prim.p_t p + | ERel n => + ((if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n))) + handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) + | ENamed n => p_enamed env n + | ECon (_, pc, ts, NONE) => box [string "[", + p_patCon env pc, + p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts, + string "]"] + | ECon (_, pc, ts, SOME e) => box [string "[", + p_patCon env pc, + space, + p_exp' true env e, + p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts, + string "]"] + | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] + | EFfiApp (m, x, es) => box [string "FFI(", + string m, + string ".", + string x, + string "(", + p_list (p_exp env o #1) es, + string "))"] + | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, + space, + p_exp' true env e2]) + | EAbs (x, t, _, e) => parenIf par (box [string "(fn", + space, + string x, + space, + string ":", + space, + p_con env t, + space, + string "=>", + space, + p_exp (E.pushERel env x t) e, + string ")"]) + | ECApp (e, c) => parenIf par (box [p_exp env e, + space, + string "[", + p_con env c, + string "]"]) + | ECAbs (x, k, e) => parenIf par (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind env k, + space, + string "=>", + space, + p_exp (E.pushCRel env x k) e]) + + | ERecord xes => box [string "{", + p_list (fn (x, e, _) => + box [p_name env x, + space, + string "=", + space, + p_exp env e]) xes, + string "}"] + | EField (e, c, {field, rest}) => + if !debug then + box [p_exp' true env e, + string ".", + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + string ".", + p_con' true env c] + | EConcat (e1, c1, e2, c2) => + parenIf par (if !debug then + box [p_exp' true env e1, + space, + string ":", + space, + p_con env c1, + space, + string "++", + space, + p_exp' true env e2, + space, + string ":", + space, + p_con env c2] + else + box [p_exp' true env e1, + space, + string "with", + space, + p_exp' true env e2]) + | ECut (e, c, {field, rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) + + | ECase (e, pes, {disc, result}) => + parenIf par (box [string "case", + space, + p_exp env e, + space, + if !debug then + box [string "in", + space, + p_con env disc, + space, + string "return", + space, + p_con env result, + space] + else + box [], + string "of", + space, + p_list_sep (box [space, string "|", space]) + (fn (p, e) => box [p_pat env p, + space, + string "=>", + space, + p_exp (E.patBinds env p) e]) pes]) + + | EWrite e => box [string "write(", + p_exp env e, + string ")"] + + | EClosure (n, es) => box [string "CLOSURE(", + p_enamed env n, + p_list_sep (string "") (fn e => box [string ", ", + p_exp env e]) es, + string ")"] + + | ELet (x, t, e1, e2) => box [string "let", + space, + string x, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e1, + space, + string "in", + newline, + p_exp (E.pushERel env x t) e2] + + | EServerCall (n, es, _, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")"] + + | EKAbs (x, e) => box [string x, + space, + string "==>", + space, + p_exp (E.pushKRel env x) e] + | EKApp (e, k) => box [p_exp env e, + string "[[", + p_kind env k, + string "]]"] + +and p_exp env = p_exp' false env + +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + +fun p_vali env (x, n, t, e, s) = + let + val xp = p_named x n + in + box [xp, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + end + +fun p_datatype env (x, n, xs, cons) = + let + val k = (KType, ErrorMsg.dummySpan) + val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs + + val xp = if !debug then + string (x ^ "__" ^ Int.toString n) + else + string x + in + box [xp, + p_list_sep (box []) (fn x => box [space, string x]) xs, + space, + string "=", + space, + p_list_sep (box [space, string "|", space]) + (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x + | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x, space, string "of", space, p_con env t]) + cons] + end + +fun p_decl env (dAll as (d, _) : decl) = + case d of + DCon (x, n, k, c) => + let + val xp = if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + in + box [string "con", + space, + xp, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + end + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] + | DVal vi => box [string "val", + space, + p_vali env vi] + | DValRec vis => + let + val env = E.declBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_vali env) vis] + end + | DExport (ek, n, _) => box [string "export", + space, + Export.p_export_kind ek, + space, + p_enamed env n, + space, + string "as", + space, + (p_con env (#2 (E.lookupENamed env n)) + handle E.UnboundNamed _ => string "UNBOUND")] + | DTable (x, n, c, s, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp (E.declBinds env dAll) ce] + | DSequence (x, n, s) => box [string "sequence", + space, + p_named x n, + space, + string "as", + space, + string s] + | DView (x, n, s, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] + | DDatabase s => box [string "database", + space, + string s] + | DCookie (x, n, c, s) => box [string "cookie", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c] + | DStyle (x, n, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s] + | DTask (e1, e2) => box [string "task", + space, + p_exp env e1, + space, + string "=", + space, + p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] + | DOnError _ => string "ONERROR" + +fun p_file env file = + let + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) + env file + in + p_list_sep newline (fn x => x) pds + end + +end diff --git a/src/core_untangle.sig b/src/core_untangle.sig new file mode 100644 index 0000000..86e039e --- /dev/null +++ b/src/core_untangle.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 CORE_UNTANGLE = sig + + val untangle : Core.file -> Core.file + +end diff --git a/src/core_untangle.sml b/src/core_untangle.sml new file mode 100644 index 0000000..a3bb559 --- /dev/null +++ b/src/core_untangle.sml @@ -0,0 +1,237 @@ +(* Copyright (c) 2008, 2013, 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 CoreUntangle :> CORE_UNTANGLE = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun default (k, s) = s + +fun exp thisGroup (e, s) = + let + fun try n = + if IS.member (thisGroup, n) then + IS.add (s, n) + else + s + in + case e of + ENamed n => try n + | EClosure (n, _) => try n + | EServerCall (n, _, _, _) => try n + | _ => s + end + +fun untangle file = + let + fun expUsed thisGroup = U.Exp.fold {con = default, + kind = default, + exp = exp thisGroup} IS.empty + + fun decl (dAll as (d, loc)) = + case d of + DValRec vis => + let + val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => + IS.add (thisGroup, n)) IS.empty vis + + val edefs = foldl (fn ((_, n, _, e, _), edefs) => + IM.insert (edefs, n, expUsed thisGroup e)) + IM.empty vis + + val used = edefs + + fun expand used = + IS.foldl (fn (n, used) => + case IM.find (edefs, n) of + NONE => used + | SOME usedHere => + if IS.isEmpty (IS.difference (usedHere, used)) then + used + else + expand (IS.union (usedHere, used))) + used used + + fun p_graph reachable = + IM.appi (fn (n, reachableHere) => + (print (Int.toString n); + print ":"; + IS.app (fn n' => (print " "; + print (Int.toString n'))) reachableHere; + print "\n")) reachable + + (*val () = print "used:\n" + val () = p_graph used*) + + fun expand reachable = + let + val changed = ref false + + val reachable = + IM.mapi (fn (n, reachableHere) => + IS.foldl (fn (n', reachableHere) => + let + val more = valOf (IM.find (reachable, n')) + in + if IS.isEmpty (IS.difference (more, reachableHere)) then + reachableHere + else + (changed := true; + IS.union (more, reachableHere)) + end) + reachableHere reachableHere) reachable + in + (reachable, !changed) + end + + fun iterate reachable = + let + val (reachable, changed) = expand reachable + in + if changed then + iterate reachable + else + reachable + end + + val reachable = iterate used + + (*val () = print "reachable:\n" + val () = p_graph reachable*) + + fun sccs (nodes, acc) = + case IS.find (fn _ => true) nodes of + NONE => acc + | SOME rep => + let + val reachableHere = valOf (IM.find (reachable, rep)) + + val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) => + if node = rep then + (nodes, scc) + else + let + val reachableThere = + valOf (IM.find (reachable, node)) + in + if IS.member (reachableThere, rep) then + (IS.delete (nodes, node), + IS.add (scc, node)) + else + (nodes, scc) + end) + (IS.delete (nodes, rep), IS.singleton rep) reachableHere + in + sccs (nodes, scc :: acc) + end + + val sccs = sccs (thisGroup, []) + + (*val () = app (fn nodes => (print "SCC:"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) + + (*val () = app (fn nodes => (print "SCC':"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun isNonrec nodes = + case IS.find (fn _ => true) nodes of + NONE => NONE + | SOME node => + let + val nodes = IS.delete (nodes, node) + val reachableHere = valOf (IM.find (reachable, node)) + in + if IS.isEmpty nodes then + if IS.member (reachableHere, node) then + NONE + else + SOME node + else + NONE + end + + val ds = map (fn nodes => + case isNonrec nodes of + SOME node => + let + val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis) + in + (DVal vi, loc) + end + | NONE => + (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc)) + sccs + in + ds + end + | _ => [dAll] + in + ListUtil.mapConcat decl file + end + +end diff --git a/src/core_util.sig b/src/core_util.sig new file mode 100644 index 0000000..835577a --- /dev/null +++ b/src/core_util.sig @@ -0,0 +1,232 @@ +(* Copyright (c) 2008, 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 CORE_UTIL = sig + +structure Kind : sig + val compare : Core.kind * Core.kind -> order + + val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB, + bind : 'context * string -> 'context} + -> ('context, Core.kind, 'state, 'abort) Search.mapfolderB + val mapfold : (Core.kind', 'state, 'abort) Search.mapfolder + -> (Core.kind, 'state, 'abort) Search.mapfolder + val map : (Core.kind' -> Core.kind') -> Core.kind -> Core.kind + val exists : (Core.kind' -> bool) -> Core.kind -> bool + val mapB : {kind : 'context -> Core.kind' -> Core.kind', + bind : 'context * string -> 'context} + -> 'context -> (Core.kind -> Core.kind) +end + +structure Con : sig + val compare : Core.con * Core.con -> order + + datatype binder = + RelK of string + | RelC of string * Core.kind + | NamedC of string * int * Core.kind * Core.con option + + val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Core.con', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Core.con, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder, + con : (Core.con', 'state, 'abort) Search.mapfolder} + -> (Core.con, 'state, 'abort) Search.mapfolder + + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con'} + -> Core.con -> Core.con + + val mapB : {kind : 'context -> Core.kind' -> Core.kind', + con : 'context -> Core.con' -> Core.con', + bind : 'context * binder -> 'context} + -> 'context -> (Core.con -> Core.con) + + val fold : {kind : Core.kind' * 'state -> 'state, + con : Core.con' * 'state -> 'state} + -> 'state -> Core.con -> 'state + + val exists : {kind : Core.kind' -> bool, + con : Core.con' -> bool} -> Core.con -> bool + + val existsB : {kind : 'context * Core.kind' -> bool, + con : 'context * Core.con' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Core.con -> bool + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state} + -> 'state -> Core.con -> Core.con * 'state +end + +structure Exp : sig + val compare : Core.exp * Core.exp -> order + + datatype binder = + RelK of string + | RelC of string * Core.kind + | NamedC of string * int * Core.kind * Core.con option + | RelE of string * Core.con + | NamedE of string * int * Core.con * Core.exp option * string + + val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Core.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Core.exp, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder, + con : (Core.con', 'state, 'abort) Search.mapfolder, + exp : (Core.exp', 'state, 'abort) Search.mapfolder} + -> (Core.exp, 'state, 'abort) Search.mapfolder + + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp'} + -> Core.exp -> Core.exp + val mapB : {kind : 'context -> Core.kind' -> Core.kind', + con : 'context -> Core.con' -> Core.con', + exp : 'context -> Core.exp' -> Core.exp', + bind : 'context * binder -> 'context} + -> 'context -> (Core.exp -> Core.exp) + + val fold : {kind : Core.kind' * 'state -> 'state, + con : Core.con' * 'state -> 'state, + exp : Core.exp' * 'state -> 'state} + -> 'state -> Core.exp -> 'state + + val foldB : {kind : 'context * Core.kind' * 'state -> 'state, + con : 'context * Core.con' * 'state -> 'state, + exp : 'context * Core.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> 'state + + val exists : {kind : Core.kind' -> bool, + con : Core.con' -> bool, + exp : Core.exp' -> bool} -> Core.exp -> bool + + val existsB : {kind : 'context * Core.kind' -> bool, + con : 'context * Core.con' -> bool, + exp : 'context * Core.exp' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Core.exp -> bool + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state} + -> 'state -> Core.exp -> Core.exp * 'state + val foldMapB : {kind : 'context * Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> Core.exp * 'state +end + +structure Decl : sig + datatype binder = datatype Exp.binder + + val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Core.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB, + decl : ('context, Core.decl', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Core.decl, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder, + con : (Core.con', 'state, 'abort) Search.mapfolder, + exp : (Core.exp', 'state, 'abort) Search.mapfolder, + decl : (Core.decl', 'state, 'abort) Search.mapfolder} + -> (Core.decl, 'state, 'abort) Search.mapfolder + + val fold : {kind : Core.kind' * 'state -> 'state, + con : Core.con' * 'state -> 'state, + exp : Core.exp' * 'state -> 'state, + decl : Core.decl' * 'state -> 'state} + -> 'state -> Core.decl -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.decl -> Core.decl * 'state + val foldMapB : {kind : 'context * Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + decl : 'context * Core.decl' * 'state -> Core.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.decl -> Core.decl * 'state + + val exists : {kind : Core.kind' -> bool, + con : Core.con' -> bool, + exp : Core.exp' -> bool, + decl : Core.decl' -> bool} -> Core.decl -> bool +end + +structure File : sig + val maxName : Core.file -> int + + datatype binder = datatype Exp.binder + + val mapfoldB : {kind : ('context, Core.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Core.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Core.exp', 'state, 'abort) Search.mapfolderB, + decl : ('context, Core.decl', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Core.file, 'state, 'abort) Search.mapfolderB + + val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder, + con : (Core.con', 'state, 'abort) Search.mapfolder, + exp : (Core.exp', 'state, 'abort) Search.mapfolder, + decl : (Core.decl', 'state, 'abort) Search.mapfolder} + -> (Core.file, 'state, 'abort) Search.mapfolder + + val mapB : {kind : 'context -> Core.kind' -> Core.kind', + con : 'context -> Core.con' -> Core.con', + exp : 'context -> Core.exp' -> Core.exp', + decl : 'context -> Core.decl' -> Core.decl', + bind : 'context * binder -> 'context} + -> 'context -> Core.file -> Core.file + + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp', + decl : Core.decl' -> Core.decl'} + -> Core.file -> Core.file + + val fold : {kind : Core.kind' * 'state -> 'state, + con : Core.con' * 'state -> 'state, + exp : Core.exp' * 'state -> 'state, + decl : Core.decl' * 'state -> 'state} + -> 'state -> Core.file -> 'state + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state, + decl : Core.decl' * 'state -> Core.decl' * 'state} + -> 'state -> Core.file -> Core.file * 'state +end + +end diff --git a/src/core_util.sml b/src/core_util.sml new file mode 100644 index 0000000..57ef16f --- /dev/null +++ b/src/core_util.sml @@ -0,0 +1,1240 @@ +(* Copyright (c) 2008-2010, 2013, 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 CoreUtil :> CORE_UTIL = struct + +open Core + +structure S = Search + +structure Kind = struct + +open Order + +fun compare ((k1, _), (k2, _)) = + case (k1, k2) of + (KType, KType) => EQUAL + | (KType, _) => LESS + | (_, KType) => GREATER + + | (KArrow (d1, r1), KArrow (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2)) + | (KArrow _, _) => LESS + | (_, KArrow _) => GREATER + + | (KName, KName) => EQUAL + | (KName, _) => LESS + | (_, KName) => GREATER + + | (KRecord k1, KRecord k2) => compare (k1, k2) + | (KRecord _, _) => LESS + | (_, KRecord _) => GREATER + + | (KUnit, KUnit) => EQUAL + | (KUnit, _) => LESS + | (_, KUnit) => GREATER + + | (KTuple ks1, KTuple ks2) => joinL compare (ks1, ks2) + | (KTuple _, _) => LESS + | (_, KTuple _) => GREATER + + | (KRel n1, KRel n2) => Int.compare (n1, n2) + | (KRel _, _) => LESS + | (_, KRel _) => GREATER + + | (KFun (_, k1), KFun (_, k2)) => compare (k1, k2) + +fun mapfoldB {kind = f, bind} = + let + fun mfk ctx k acc = + S.bindP (mfk' ctx k acc, f 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)) + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +fun mapfold fk = + mapfoldB {kind = fn () => fk, + bind = fn ((), _) => ()} () + +fun map f k = + case mapfold (fn k => fn () => S.Continue (f k, ())) k () of + S.Return () => raise Fail "CoreUtil.Kind.map" + | S.Continue (k, ()) => k + +fun mapB {kind, bind} ctx k = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + bind = bind} ctx k () of + S.Continue (k, ()) => k + | S.Return _ => raise Fail "CoreUtil.Kind.mapB: Impossible" + +fun exists f k = + case mapfold (fn k => fn () => + if f k then + S.Return () + else + S.Continue (k, ())) k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure Con = struct + +open Order + +fun compare ((c1, _), (c2, _)) = + case (c1, c2) of + (TFun (d1, r1), TFun (d2, r2)) => join (compare (d1, d2), fn () => compare (r1, r2)) + | (TFun _, _) => LESS + | (_, TFun _) => GREATER + + | (TCFun (x1, k1, r1), TCFun (x2, k2, r2)) => + join (String.compare (x1, x2), + fn () => join (Kind.compare (k1, k2), + fn () => compare (r1, r2))) + | (TCFun _, _) => LESS + | (_, TCFun _) => GREATER + + | (TRecord c1, TRecord c2) => compare (c1, c2) + | (TRecord _, _) => LESS + | (_, TRecord _) => GREATER + + | (CRel n1, CRel n2) => Int.compare (n1, n2) + | (CRel _, _) => LESS + | (_, CRel _) => GREATER + + | (CNamed n1, CNamed n2) => Int.compare (n1, n2) + | (CNamed _, _) => LESS + | (_, CNamed _) => GREATER + + | (CFfi (m1, s1), CFfi (m2, s2)) => join (String.compare (m1, m2), + fn () => String.compare (s1, s2)) + | (CFfi _, _) => LESS + | (_, CFfi _) => GREATER + + | (CApp (f1, x1), CApp (f2, x2)) => join (compare (f1, f2), + fn () => compare (x1, x2)) + | (CApp _, _) => LESS + | (_, CApp _) => GREATER + + | (CAbs (x1, k1, b1), CAbs (x2, k2, b2)) => + join (String.compare (x1, x2), + fn () => join (Kind.compare (k1, k2), + fn () => compare (b1, b2))) + | (CAbs _, _) => LESS + | (_, CAbs _) => GREATER + + | (CName s1, CName s2) => String.compare (s1, s2) + | (CName _, _) => LESS + | (_, CName _) => GREATER + + | (CRecord (k1, xvs1), CRecord (k2, xvs2)) => + join (Kind.compare (k1, k2), + fn () => + let + val sort = ListMergeSort.sort (fn ((x1, _), (x2, _)) => + compare (x1, x2) = GREATER) + in + joinL (fn ((x1, v1), (x2, v2)) => + join (compare (x1, x2), + fn () => compare (v1, v2))) (sort xvs1, sort xvs2) + end) + | (CRecord _, _) => LESS + | (_, CRecord _) => GREATER + + | (CConcat (f1, s1), CConcat (f2, s2)) => + join (compare (f1, f2), + fn () => compare (s1, s2)) + | (CConcat _, _) => LESS + | (_, CConcat _) => GREATER + + | (CMap (d1, r1), CMap (d2, r2)) => + join (Kind.compare (d1, d2), + fn () => Kind.compare (r1, r2)) + | (CMap _, _) => LESS + | (_, CMap _) => GREATER + + | (CUnit, CUnit) => EQUAL + | (CUnit, _) => LESS + | (_, CUnit) => GREATER + + | (CTuple cs1, CTuple cs2) => joinL compare (cs1, cs2) + | (CTuple _, _) => LESS + | (_, CTuple _) => GREATER + + | (CProj (c1, n1), CProj (c2, n2)) => join (Int.compare (n1, n2), + fn () => compare (c1, c2)) + | (CProj _, _) => LESS + | (_, CProj _) => GREATER + + | (CKAbs (_, c1), CKAbs (_, c2)) => compare (c1, c2) + | (CKAbs _, _) => LESS + | (_, CKAbs _) => GREATER + + | (CKApp (c1, k1), CKApp (c2, k2)) => + join (compare (c1, c2), + fn () => Kind.compare (k1, k2)) + | (CKApp _, _) => LESS + | (_, CKApp _) => GREATER + + | (TKFun (_, c1), TKFun (_, c2)) => compare (c1, c2) + +datatype binder = + RelK of string + | RelC of string * kind + | NamedC of string * int * kind * con option + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun mfc ctx c acc = + S.bindP (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 (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (x, k', c'), loc))) + | TRecord c => + S.map2 (mfc ctx c, + fn c' => + (TRecord c', loc)) + + | CRel _ => S.return2 cAll + | CNamed _ => S.return2 cAll + | CFfi _ => 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)) + + | 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 + +fun mapfold {kind = fk, con = fc} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + bind = fn ((), _) => ()} () + +fun map {kind, con} c = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ())} c () of + S.Return () => raise Fail "Core_util.Con.map" + | S.Continue (c, ()) => c + +fun mapB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + bind = bind} ctx c () of + S.Continue (c, ()) => c + | S.Return _ => raise Fail "CoreUtil.Con.mapB: Impossible" + +fun fold {kind, con} s c = + case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), + con = fn c => fn s => S.Continue (c, con (c, s))} c s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Con.fold: Impossible" + +fun exists {kind, con} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ())} k () of + S.Return _ => true + | S.Continue _ => false + +fun existsB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + bind = bind} ctx c () of + S.Return _ => true + | S.Continue _ => false + +fun foldMap {kind, con} s c = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s))} c s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Con.foldMap: Impossible" + +end + +structure Exp = struct + +open Order + +fun pcCompare (pc1, pc2) = + case (pc1, pc2) of + (PConVar n1, PConVar n2) => Int.compare (n1, n2) + | (PConVar _, _) => LESS + | (_, PConVar _) => GREATER + + | (PConFfi {mod = m1, datatyp = d1, con = c1, ...}, + PConFfi {mod = m2, datatyp = d2, con = c2, ...}) => + join (String.compare (m1, m2), + fn () => join (String.compare (d1, d2), + fn () => String.compare (c1, c2))) + +fun pCompare ((p1, _), (p2, _)) = + case (p1, p2) of + (PVar _, PVar _) => EQUAL + | (PVar _, _) => LESS + | (_, PVar _) => GREATER + + | (PPrim p1, PPrim p2) => Prim.compare (p1, p2) + | (PPrim _, _) => LESS + | (_, PPrim _) => GREATER + + | (PCon (_, pc1, _, po1), PCon (_, pc2, _, po2)) => + join (pcCompare (pc1, pc2), + fn () => joinO pCompare (po1, po2)) + | (PCon _, _) => LESS + | (_, PCon _) => GREATER + + | (PRecord xps1, PRecord xps2) => + joinL (fn ((x1, p1, _), (x2, p2, _)) => + join (String.compare (x1, x2), + fn () => pCompare (p1, p2))) (xps1, xps2) + +fun fmCompare (fm1, fm2) = + case (fm1, fm2) of + (None, None) => EQUAL + | (None, _) => LESS + | (_, None) => GREATER + + | (Error, Error) => EQUAL + +fun compare ((e1, _), (e2, _)) = + case (e1, e2) of + (EPrim p1, EPrim p2) => Prim.compare (p1, p2) + | (EPrim _, _) => LESS + | (_, EPrim _) => GREATER + + | (ERel n1, ERel n2) => Int.compare (n1, n2) + | (ERel _, _) => LESS + | (_, ERel _) => GREATER + + | (ENamed n1, ENamed n2) => Int.compare (n1, n2) + | (ENamed _, _) => LESS + | (_, ENamed _) => GREATER + + | (ECon (_, pc1, _, eo1), ECon (_, pc2, _, eo2)) => + join (pcCompare (pc1, pc2), + fn () => joinO compare (eo1, eo2)) + | (ECon _, _) => LESS + | (_, ECon _) => GREATER + + | (EFfi (f1, x1), EFfi (f2, x2)) => + join (String.compare (f1, f2), + fn () => String.compare (x1, x2)) + | (EFfi _, _) => LESS + | (_, EFfi _) => GREATER + + | (EFfiApp (f1, x1, es1), EFfiApp (f2, x2, es2)) => + join (String.compare (f1, f2), + fn () => join (String.compare (x1, x2), + fn () => joinL (fn ((e1, _), (e2, _)) => compare (e1, e2))(es1, es2))) + | (EFfiApp _, _) => LESS + | (_, EFfiApp _) => GREATER + + | (EApp (f1, x1), EApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) + | (EApp _, _) => LESS + | (_, EApp _) => GREATER + + | (EAbs (_, _, _, e1), EAbs (_, _, _, e2)) => compare (e1, e2) + | (EAbs _, _) => LESS + | (_, EAbs _) => GREATER + + | (ECApp (f1, x1), ECApp (f2, x2)) => + join (compare (f1, f2), + fn () => Con.compare (x1, x2)) + | (ECApp _, _) => LESS + | (_, ECApp _) => GREATER + + | (ECAbs (_, _, e1), ECAbs (_, _, e2)) => compare (e1, e2) + | (ECAbs _, _) => LESS + | (_, ECAbs _) => GREATER + + | (ERecord xes1, ERecord xes2) => + joinL (fn ((x1, e1, _), (x2, e2, _)) => + join (Con.compare (x1, x2), + fn () => compare (e1, e2))) (xes1, xes2) + | (ERecord _, _) => LESS + | (_, ERecord _) => GREATER + + | (EField (e1, c1, _), EField (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (EField _, _) => LESS + | (_, EField _) => GREATER + + | (EConcat (x1, _, y1, _), EConcat (x2, _, y2, _)) => + join (compare (x1, x2), + fn () => compare (y1, y2)) + | (EConcat _, _) => LESS + | (_, EConcat _) => GREATER + + | (ECut (e1, c1, _), ECut (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (ECut _, _) => LESS + | (_, ECut _) => GREATER + + | (ECutMulti (e1, c1, _), ECutMulti (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (ECutMulti _, _) => LESS + | (_, ECutMulti _) => GREATER + + | (ECase (e1, pes1, _), ECase (e2, pes2, _)) => + join (compare (e1, e2), + fn () => joinL (fn ((p1, e1), (p2, e2)) => + join (pCompare (p1, p2), + fn () => compare (e1, e2))) (pes1, pes2)) + | (ECase _, _) => LESS + | (_, ECase _) => GREATER + + | (EWrite e1, EWrite e2) => compare (e1, e2) + | (EWrite _, _) => LESS + | (_, EWrite _) => GREATER + + | (EClosure (n1, es1), EClosure (n2, es2)) => + join (Int.compare (n1, n2), + fn () => joinL compare (es1, es2)) + | (EClosure _, _) => LESS + | (_, EClosure _) => GREATER + + | (ELet (_, _, x1, e1), ELet (_, _, x2, e2)) => + join (compare (x1, x2), + fn () => compare (e1, e2)) + | (ELet _, _) => LESS + | (_, ELet _) => GREATER + + | (EServerCall (n1, es1, _, fm1), EServerCall (n2, es2, _, fm2)) => + join (Int.compare (n1, n2), + fn () => join (fmCompare (fm1, fm2), + fn () => joinL compare (es1, es2))) + | (EServerCall _, _) => LESS + | (_, EServerCall _) => GREATER + + | (EKAbs (_, e1), EKAbs (_, e2)) => compare (e1, e2) + | (EKAbs _, _) => LESS + | (_, EKAbs _) => GREATER + + | (EKApp (e1, k1), EKApp (e2, k2)) => + join (compare (e1, e2), + fn () => Kind.compare (k1, k2)) + +datatype binder = + RelK of string + | RelC of string * kind + | NamedC of string * int * kind * con option + | RelE of string * con + | NamedE of string * int * con * exp option * string + +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 mfe ctx e acc = + S.bindP (mfe' ctx e acc, fe ctx) + + and mfet ctx (e, t) = + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => (e', t'))) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | ECon (dk, pc, cs, NONE) => + S.bind2 (mfpc ctx pc, + fn pc' => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (ECon (dk, pc', cs', NONE), loc))) + | ECon (dk, pc, cs, SOME e) => + S.bind2 (mfpc ctx pc, + fn pc' => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (ListUtil.mapfold (mfc ctx) cs, + fn cs' => + (ECon (dk, pc', cs', SOME e'), loc)))) + | EFfi _ => S.return2 eAll + | EFfiApp (m, x, es) => + S.map2 (ListUtil.mapfold (mfet ctx) es, + fn es' => + (EFfiApp (m, x, es'), loc)) + | 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 (x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (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))))) + + | EWrite e => + S.map2 (mfe ctx e, + fn e' => + (EWrite e', loc)) + + | EClosure (n, es) => + S.map2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + (EClosure (n, es'), loc)) + + | ELet (x, t, e1, e2) => + S.bind2 (mfc ctx t, + fn t' => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, + fn e2' => + (ELet (x, t', e1', e2'), loc)))) + + | EServerCall (n, es, t, fm) => + S.bind2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + S.map2 (mfc ctx t, + fn t' => + (EServerCall (n, es', t', fm), loc))) + + | 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 (mfpc ctx pc, + fn pc' => + 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 mfpc ctx pc = + case pc of + PConVar _ => S.return2 pc + | PConFfi {mod = m, datatyp, params, con, arg, kind} => + S.map2 ((case arg of + NONE => S.return2 NONE + | SOME c => + let + val k = (KType, ErrorMsg.dummySpan) + val ctx' = foldl (fn (x, ctx) => bind (ctx, RelC (x, k))) ctx params + in + S.map2 (mfc ctx' c, SOME) + end), + fn arg' => + PConFfi {mod = m, datatyp = datatyp, params = params, + con = con, arg = arg', kind = kind}) + in + mfe + end + +fun mapfold {kind = fk, con = fc, exp = fe} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + exp = fn () => fe, + bind = fn ((), _) => ()} () + +fun mapB {kind, con, exp, bind} ctx e = + 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, ()), + bind = bind} ctx e () of + S.Continue (e, ()) => e + | S.Return _ => raise Fail "CoreUtil.Exp.mapB: Impossible" + +fun map {kind, con, exp} e = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ()), + exp = fn e => fn () => S.Continue (exp e, ())} e () of + S.Return () => raise Fail "Core_util.Exp.map" + | S.Continue (e, ()) => e + +fun fold {kind, con, exp} s e = + case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), + con = fn c => fn s => S.Continue (c, con (c, s)), + exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible" + +fun foldB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (k, kind (ctx, k, s)), + con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Exp.foldB: Impossible" + +fun exists {kind, con, exp} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ())} k () of + S.Return _ => true + | S.Continue _ => false + +fun existsB {kind, con, exp, bind} ctx k = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx k () of + S.Return _ => true + | S.Continue _ => false + +fun foldMap {kind, con, exp} s e = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s))} e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible" + +fun foldMapB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (kind (ctx, k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMapB: Impossible" + +end + +structure Decl = struct + +datatype binder = datatype Exp.binder + +fun mapfoldB {kind = fk, con = fc, exp = fe, 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'} + + val mfe = Exp.mapfoldB {kind = fk, con = fc, exp = fe, bind = bind} + + fun mfd ctx d acc = + S.bindP (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) => + let + val k = (KType, loc) + val k' = foldl (fn (_, k') => (KArrow (k, k'), loc)) k xs + val ctx' = bind (ctx, NamedC (x, n, k', NONE)) + in + 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')) + end) dts, + fn dts' => + (DDatatype dts', loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + let + val ctx = foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) + ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (DValRec vis', loc)) + end + | DExport _ => S.return2 dAll + | DTable (x, n, c, s, pe, pc, ce, cc) => + let + val loc = #2 ce + val ct = (CFfi ("Basis", "sql_table"), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + val ct = (CApp (ct, cc), loc) + val ctx' = bind (ctx, NamedE (x, n, ct, NONE, s)) + in + 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 (x, n, c', s, pe', pc', ce', cc'), loc)))))) + end + | DSequence _ => S.return2 dAll + | DView (x, n, s, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (x, n, s, e', c'), loc))) + | DDatabase _ => S.return2 dAll + | DCookie (x, n, c, s) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (x, n, c', s), 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 e => + S.map2 (mfe ctx e, + fn e' => + (DPolicy e', loc)) + + | DOnError _ => S.return2 dAll + + and mfvi ctx (x, n, t, e, s) = + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (x, n, t', e', s))) + in + mfd + end + +fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + exp = fn () => fe, + decl = fn () => fd, + bind = fn ((), _) => ()} () + +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)), + exp = fn e => fn s => S.Continue (e, exp (e, s)), + decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible" + +fun foldMap {kind, con, exp, decl} s d = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" + +fun foldMapB {kind, con, exp, decl, bind} ctx s d = + case mapfoldB {kind = fn ctx => fn k => fn s => S.Continue (kind (ctx, k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible" + +fun exists {kind, con, exp, decl} d = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ()), + decl = fn d => fn () => + if decl d then + S.Return () + else + S.Continue (d, ())} d () of + S.Return _ => true + | S.Continue _ => false + +end + +structure File = struct + +datatype binder = datatype Exp.binder + +fun mapfoldB (all as {bind, ...}) = + let + val mfd = Decl.mapfoldB all + + fun mff ctx ds = + case ds of + nil => S.return2 nil + | d :: ds' => + S.bind2 (mfd ctx d, + fn d' => + let + val ctx' = + case #1 d' of + DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c)) + | DDatatype dts => + foldl (fn ((x, n, xs, xncs), ctx) => + let + val loc = #2 d' + val k = (KType, loc) + val k' = foldl (fn (_, k') => (KArrow (k, k'), loc)) k xs + + val ctx = bind (ctx, NamedC (x, n, k', NONE)) + val t = (CNamed n, #2 d') + val t = ListUtil.foldli (fn (i, _, t) => + (CApp (t, (CRel i, loc)), loc)) + t xs + in + foldl (fn ((x, n, to), ctx) => + let + val t = case to of + NONE => t + | SOME t' => (TFun (t', t), #2 d') + val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) + t xs + in + bind (ctx, NamedE (x, n, t, NONE, "")) + end) + ctx xncs + end) + ctx dts + | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) + | DValRec vis => + foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s))) + ctx vis + | DExport _ => ctx + | DTable (x, n, c, s, _, pc, _, cc) => + let + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_table"), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + val ct = (CApp (ct, cc), loc) + in + bind (ctx, NamedE (x, n, ct, NONE, s)) + end + | DSequence (x, n, s) => + let + val t = (CFfi ("Basis", "sql_sequence"), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end + | DView (x, n, s, _, c) => + let + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, n, ct, NONE, s)) + end + | DDatabase _ => ctx + | DCookie (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "http_cookie"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end + | DStyle (x, n, s) => + let + val t = (CFfi ("Basis", "css_class"), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end + | DTask _ => ctx + | DPolicy _ => ctx + | DOnError _ => ctx + in + S.map2 (mff ctx' ds', + fn ds' => + d' :: ds') + end) + in + mff + end + +fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + exp = fn () => fe, + decl = fn () => fd, + bind = fn ((), _) => ()} () + +fun mapB {kind, con, exp, decl, bind} ctx ds = + 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 ds () of + S.Continue (ds, ()) => ds + | S.Return _ => raise Fail "CoreUtil.File.mapB: Impossible" + +fun map {kind, con, exp, decl} ds = + mapB {kind = fn () => kind, + con = fn () => con, + exp = fn () => exp, + decl = fn () => decl, + bind = fn _ => ()} () ds + +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)), + exp = fn e => fn s => S.Continue (e, exp (e, s)), + decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.File.fold: Impossible" + +fun foldMap {kind, con, exp, decl} s d = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.File.foldMap: Impossible" + +val maxName = foldl (fn ((d, _) : decl, count) => + case d of + DCon (_, n, _, _) => Int.max (n, count) + | DDatatype dts => foldl (fn ((_, n, _, ns), count) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns) count dts + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) + | DSequence (_, n, _) => Int.max (n, count) + | DView (_, n, _, _, _) => Int.max (n, count) + | DDatabase _ => count + | DCookie (_, n, _, _) => Int.max (n, count) + | DStyle (_, n, _) => Int.max (n, count) + | DTask _ => count + | DPolicy _ => count + | DOnError _ => count) 0 + +end + +end diff --git a/src/corify.sig b/src/corify.sig new file mode 100644 index 0000000..0e1bb80 --- /dev/null +++ b/src/corify.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 CORIFY = sig + + val corify : Expl.file -> Core.file + +end diff --git a/src/corify.sml b/src/corify.sml new file mode 100644 index 0000000..19cd3ec --- /dev/null +++ b/src/corify.sml @@ -0,0 +1,1330 @@ +(* Copyright (c) 2008-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 Corify :> CORIFY = struct + +structure EM = ErrorMsg +structure L = Expl +structure L' = Core + +structure IM = IntBinaryMap +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +fun doRestify k (mods, s) = + let + val s = if String.isPrefix "wrap_" s then + String.extract (s, 5, NONE) + else + s + val s = String.concatWith "/" (rev (s :: mods)) + val s = String.implode (List.filter (fn ch => ch <> #"$") (String.explode s)) + in + Settings.rewrite k s + end + +val relify = CharVector.map (fn #"/" => #"_" + | ch => ch) + +local + val count = ref 0 +in + +fun reset v = count := v + +fun alloc () = + let + val r = !count + in + count := r + 1; + r + end + +fun getCounter () = !count +fun setCounter n = count := n + +end + +structure St : sig + type t + + val empty : t + + val debug : t -> unit + + val name : t -> string list + + val enter : t * string list -> t + val leave : t -> {outer : t, inner : t} + val ffi : string -> L'.con SM.map -> (string * string list * L'.con option * L'.datatype_kind) SM.map -> t + + val basisIs : t * int -> t + val lookupBasis : t -> int option + + datatype core_con = + CNormal of int + | CFfi of string + val bindCon : t -> string -> int -> t * int + val lookupConById : t -> int -> int option + val lookupConByName : t -> string -> core_con + + val bindConstructor : t -> string -> int -> t * int + val bindConstructorAs : t -> string -> int -> L'.patCon -> t + val lookupConstructorByNameOpt : t -> string -> L'.patCon option + val lookupConstructorByName : t -> string -> L'.patCon + val lookupConstructorById : t -> int -> L'.patCon + val lookupConstructorByIdOpt : t -> int -> L'.patCon option + + datatype core_val = + ENormal of int + | EFfi of string * L'.con + val bindVal : t -> string -> int -> t * int + val bindConstructorVal : t -> string -> int -> int -> t + val lookupValById : t -> int -> int option + val lookupValByName : t -> string -> core_val + + val bindStr : t -> string -> int -> t -> t + val lookupStrById : t -> int -> t + val lookupStrByIdOpt : t -> int -> t option + val lookupStrByName : string * t -> t + val lookupStrByNameOpt : string * t -> t option + + val bindFunctor : t -> string -> int -> string -> int -> L.str -> t + val lookupFunctorById : t -> int -> string * int * L.str + val lookupFunctorByIdOpt : t -> int -> (string * int * L.str) option + val lookupFunctorByName : string * t -> string * int * L.str +end = struct + +datatype flattening = + FNormal of {name : string list, + cons : int SM.map, + constructors : L'.patCon SM.map, + vals : int SM.map, + strs : flattening SM.map, + funs : (string * int * L.str) SM.map} + | FFfi of {mod : string, + vals : L'.con SM.map, + constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map} + +type t = { + basis : int option, + cons : int IM.map, + constructors : L'.patCon IM.map, + vals : int IM.map, + strs : flattening IM.map, + funs : (string * int * L.str) IM.map, + current : flattening, + nested : flattening list +} + +val empty = { + basis = NONE, + cons = IM.empty, + constructors = IM.empty, + vals = IM.empty, + strs = IM.empty, + funs = IM.empty, + current = FNormal { name = [], cons = SM.empty, constructors = SM.empty, + vals = SM.empty, strs = SM.empty, funs = SM.empty }, + nested = [] +} + +fun debug ({current = FNormal {cons, constructors, vals, strs, funs, ...}, ...} : t) = + print ("cons: " ^ Int.toString (SM.numItems cons) ^ "; " + ^ "constructors: " ^ Int.toString (SM.numItems constructors) ^ "; " + ^ "vals: " ^ Int.toString (SM.numItems vals) ^ "; " + ^ "strs: " ^ Int.toString (SM.numItems strs) ^ "; " + ^ "funs: " ^ Int.toString (SM.numItems funs) ^ "\n") + | debug _ = print "Not normal!\n" + +fun name ({current = FNormal {name, ...}, ...} : t) = name + | name {current = FFfi {mod = name, ...}, ...} = [name] + +fun basisIs ({cons, constructors, vals, strs, funs, current, nested, ...} : t, basis) = + {basis = SOME basis, + cons = cons, + constructors = constructors, + vals = vals, + strs = strs, + funs = funs, + current = current, + nested = nested} + +fun lookupBasis ({basis, ...} : t) = basis + +datatype core_con = + CNormal of int + | CFfi of string + +datatype core_val = + ENormal of int + | EFfi of string * L'.con + +fun bindCon {basis, cons, constructors, vals, strs, funs, current, nested} s n = + let + val n' = alloc () + + val current = + case current of + FFfi _ => raise Fail "Binding inside FFfi" + | FNormal {name, cons, constructors, vals, strs, funs} => + FNormal {name = name, + cons = SM.insert (cons, s, n'), + constructors = constructors, + vals = vals, + strs = strs, + funs = funs} + in + ({basis = basis, + cons = IM.insert (cons, n, n'), + constructors = constructors, + vals = vals, + strs = strs, + funs = funs, + current = current, + nested = nested}, + n') + end + +fun lookupConById ({cons, ...} : t) n = IM.find (cons, n) + +fun lookupConByName ({current, ...} : t) x = + case current of + FFfi {mod = m, ...} => CFfi m + | FNormal {cons, ...} => + case SM.find (cons, x) of + NONE => raise Fail ("Corify.St.lookupConByName " ^ x) + | SOME n => CNormal n + +fun bindVal {basis, cons, constructors, vals, strs, funs, current, nested} s n = + let + val n' = alloc () + + val current = + case current of + FFfi _ => raise Fail "Binding inside FFfi" + | FNormal {name, cons, constructors, vals, strs, funs} => + FNormal {name = name, + cons = cons, + constructors = constructors, + vals = SM.insert (vals, s, n'), + strs = strs, + funs = funs} + in + ({basis = basis, + cons = cons, + constructors = constructors, + vals = IM.insert (vals, n, n'), + strs = strs, + funs = funs, + current = current, + nested = nested}, + n') + end + +fun bindConstructorVal {basis, cons, constructors, vals, strs, funs, current, nested} s n n' = + let + val current = + case current of + FFfi _ => raise Fail "Binding inside FFfi" + | FNormal {name, cons, constructors, vals, strs, funs} => + FNormal {name = name, + cons = cons, + constructors = constructors, + vals = SM.insert (vals, s, n'), + strs = strs, + funs = funs} + in + {basis = basis, + cons = cons, + constructors = constructors, + vals = IM.insert (vals, n, n'), + strs = strs, + funs = funs, + current = current, + nested = nested} + end + + +fun lookupValById ({vals, ...} : t) n = IM.find (vals, n) + +fun lookupValByName ({current, ...} : t) x = + case current of + FFfi {mod = m, vals, ...} => + (case SM.find (vals, x) of + NONE => raise Fail ("Corify.St.lookupValByName: no type for FFI val " ^ x) + | SOME t => EFfi (m, t)) + | FNormal {name, vals, ...} => + case SM.find (vals, x) of + NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." (rev name) ^ "." ^ x) + | SOME n => ENormal n + +fun bindConstructorAs {basis, cons, constructors, vals, strs, funs, current, nested} s n c' = + let + val current = + case current of + FFfi _ => raise Fail "Binding inside FFfi" + | FNormal {name, cons, constructors, vals, strs, funs} => + FNormal {name = name, + cons = cons, + constructors = SM.insert (constructors, s, c'), + vals = vals, + strs = strs, + funs = funs} + in + {basis = basis, + cons = cons, + constructors = IM.insert (constructors, n, c'), + vals = vals, + strs = strs, + funs = funs, + current = current, + nested = nested} + end + +fun bindConstructor st s n = + let + val n' = alloc () + val c' = L'.PConVar n' + in + (bindConstructorAs st s n c', n') + end + +fun lookupConstructorById ({constructors, ...} : t) n = + case IM.find (constructors, n) of + NONE => raise Fail "Corify.St.lookupConstructorById" + | SOME x => x + +fun lookupConstructorByIdOpt ({constructors, ...} : t) n = + IM.find (constructors, n) + +fun lookupConstructorByNameOpt ({current, ...} : t) x = + case current of + FFfi {mod = m, constructors, ...} => + (case SM.find (constructors, x) of + NONE => NONE + | SOME (n, xs, to, dk) => SOME (L'.PConFfi {mod = m, datatyp = n, params = xs, con = x, arg = to, kind = dk})) + | FNormal {constructors, ...} => + case SM.find (constructors, x) of + NONE => NONE + | SOME n => SOME n + +fun lookupConstructorByName ({current, ...} : t) x = + case current of + FFfi {mod = m, constructors, ...} => + (case SM.find (constructors, x) of + NONE => raise Fail "Corify.St.lookupConstructorByName [1]" + | SOME (n, xs, to, dk) => L'.PConFfi {mod = m, datatyp = n, params = xs, con = x, arg = to, kind = dk}) + | FNormal {constructors, ...} => + case SM.find (constructors, x) of + NONE => raise Fail "Corify.St.lookupConstructorByName [2]" + | SOME n => n + +fun enter ({basis, cons, constructors, vals, strs, funs, current, nested}, name) = + {basis = basis, + cons = cons, + constructors = constructors, + vals = vals, + strs = strs, + funs = funs, + current = FNormal {name = name, + cons = SM.empty, + constructors = SM.empty, + vals = SM.empty, + strs = SM.empty, + funs = SM.empty}, + nested = current :: nested} + +fun dummy (b, f) = {basis = b, + cons = IM.empty, + constructors = IM.empty, + vals = IM.empty, + strs = IM.empty, + funs = IM.empty, + current = f, + nested = []} + +fun leave {basis, cons, constructors, vals, strs, funs, current, nested = m1 :: rest} = + {outer = {basis = basis, + cons = cons, + constructors = constructors, + vals = vals, + strs = strs, + funs = funs, + current = m1, + nested = rest}, + inner = dummy (basis, current)} + | leave _ = raise Fail "Corify.St.leave" + +fun ffi m vals constructors = dummy (NONE, FFfi {mod = m, vals = vals, constructors = constructors}) + +fun bindStr ({basis, cons, constructors, vals, strs, funs, + current = FNormal {name, cons = mcons, constructors = mconstructors, + vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) + x n ({current = f, ...} : t) = + {basis = basis, + cons = cons, + constructors = constructors, + vals = vals, + strs = IM.insert (strs, n, f), + funs = funs, + current = FNormal {name = name, + cons = mcons, + constructors = mconstructors, + vals = mvals, + strs = SM.insert (mstrs, x, f), + funs = mfuns}, + nested = nested} + | bindStr _ _ _ _ = raise Fail "Corify.St.bindStr" + +fun lookupStrById ({basis, strs, ...} : t) n = + case IM.find (strs, n) of + NONE => raise Fail ("Corify.St.lookupStrById(" ^ Int.toString n ^ ")") + | SOME f => dummy (basis, f) + +fun lookupStrByIdOpt ({basis, strs, ...} : t) n = + case IM.find (strs, n) of + NONE => NONE + | SOME f => SOME (dummy (basis, f)) + +fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) = + (case SM.find (strs, m) of + NONE => raise Fail "Corify.St.lookupStrByName [1]" + | SOME f => dummy (basis, f)) + | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName [2]" + +fun lookupStrByNameOpt (m, {basis, current = FNormal {strs, ...}, ...} : t) = + (case SM.find (strs, m) of + NONE => NONE + | SOME f => SOME (dummy (basis, f))) + | lookupStrByNameOpt _ = NONE + +fun bindFunctor ({basis, cons, constructors, vals, strs, funs, + current = FNormal {name, cons = mcons, constructors = mconstructors, + vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) + x n xa na str = + {basis = basis, + cons = cons, + constructors = constructors, + vals = vals, + strs = strs, + funs = IM.insert (funs, n, (xa, na, str)), + current = FNormal {name = name, + cons = mcons, + constructors = mconstructors, + vals = mvals, + strs = mstrs, + funs = SM.insert (mfuns, x, (xa, na, str))}, + nested = nested} + | bindFunctor _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" + +fun lookupFunctorById ({funs, ...} : t) n = + case IM.find (funs, n) of + NONE => raise Fail "Corify.St.lookupFunctorById" + | SOME v => v + +fun lookupFunctorByIdOpt ({funs, ...} : t) n = + IM.find (funs, n) + +fun lookupFunctorByName (m, {current = FNormal {funs, ...}, ...} : t) = + (case SM.find (funs, m) of + NONE => raise Fail ("Corify.St.lookupFunctorByName " ^ m ^ "[1]") + | SOME v => v) + | lookupFunctorByName _ = raise Fail "Corify.St.lookupFunctorByName [2]" + +end + + +fun corifyKind (k, loc) = + case k of + L.KType => (L'.KType, loc) + | L.KArrow (k1, k2) => (L'.KArrow (corifyKind k1, corifyKind k2), loc) + | L.KName => (L'.KName, loc) + | L.KRecord k => (L'.KRecord (corifyKind k), loc) + | L.KUnit => (L'.KUnit, loc) + | L.KTuple ks => (L'.KTuple (map corifyKind ks), loc) + + | L.KRel n => (L'.KRel n, loc) + | L.KFun (x, k) => (L'.KFun (x, corifyKind k), loc) + +fun corifyCon st (c, loc) = + case c of + L.TFun (t1, t2) => (L'.TFun (corifyCon st t1, corifyCon st t2), loc) + | L.TCFun (x, k, t) => (L'.TCFun (x, corifyKind k, corifyCon st t), loc) + | L.TKFun (x, t) => (L'.TKFun (x, corifyCon st t), loc) + | L.TRecord c => (L'.TRecord (corifyCon st c), loc) + + | L.CRel n => (L'.CRel n, loc) + | L.CNamed n => + (case St.lookupConById st n of + NONE => (L'.CNamed n, loc) + | SOME n => (L'.CNamed n, loc)) + | L.CModProj (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupConByName st x of + St.CNormal n => (L'.CNamed n, loc) + | St.CFfi m => + if (m, x) = ("Basis", "unit") then + (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc) + else + (L'.CFfi (m, x), loc) + end + + | L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc) + | L.CAbs (x, k, c) => (L'.CAbs (x, corifyKind k, corifyCon st c), loc) + + | L.CKApp (c1, k) => (L'.CKApp (corifyCon st c1, corifyKind k), loc) + | L.CKAbs (x, c) => (L'.CKAbs (x, corifyCon st c), loc) + + | L.CName s => (L'.CName s, loc) + + | L.CRecord (k, xcs) => + (L'.CRecord (corifyKind k, map (fn (c1, c2) => (corifyCon st c1, corifyCon st c2)) xcs), loc) + | L.CConcat (c1, c2) => (L'.CConcat (corifyCon st c1, corifyCon st c2), loc) + | L.CMap (k1, k2) => (L'.CMap (corifyKind k1, corifyKind k2), loc) + | L.CUnit => (L'.CUnit, loc) + + | L.CTuple cs => (L'.CTuple (map (corifyCon st) cs), loc) + | L.CProj (c, n) => (L'.CProj (corifyCon st c, n), loc) + +fun corifyPatCon st pc = + case pc of + L.PConVar n => St.lookupConstructorById st n + | L.PConProj (m1, ms, x) => + let + val st = St.lookupStrById st m1 + val st = foldl St.lookupStrByName st ms + in + St.lookupConstructorByName st x + end + +fun corifyPat st (p, loc) = + case p of + L.PVar (x, t) => (L'.PVar (x, corifyCon st t), loc) + | L.PPrim p => (L'.PPrim p, loc) + | L.PCon (dk, pc, ts, po) => (L'.PCon (dk, corifyPatCon st pc, map (corifyCon st) ts, + Option.map (corifyPat st) po), loc) + | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, corifyPat st p, corifyCon st t)) xps), loc) + +fun corifyExp st (e, loc) = + case e of + L.EPrim p => (L'.EPrim p, loc) + | L.ERel n => (L'.ERel n, loc) + | L.ENamed n => + (case St.lookupValById st n of + NONE => (L'.ENamed n, loc) + | SOME n => (L'.ENamed n, loc)) + | L.EModProj (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupConstructorByNameOpt st x of + SOME (pc as L'.PConFfi {mod = m, datatyp, params, arg, kind, ...}) => + let + val args = ListUtil.mapi (fn (i, _) => (L'.CRel i, loc)) params + val e = case arg of + NONE => (L'.ECon (kind, pc, args, NONE), loc) + | SOME dom => (L'.EAbs ("x", dom, (L'.CFfi (m, datatyp), loc), + (L'.ECon (kind, pc, args, SOME (L'.ERel 0, loc)), loc)), loc) + + val k = (L'.KType, loc) + in + foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc)) e params + end + | _ => + case St.lookupValByName st x of + St.ENormal n => (L'.ENamed n, loc) + | St.EFfi (m, t) => + case t of + (L'.CApp ((L'.CFfi ("Basis", "transaction"), _), dom), _) => + (L'.EAbs ("arg", dom, (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), + (L'.EFfiApp (m, x, []), loc)), loc) + | t as (L'.TFun _, _) => + let + fun getArgs (all as (t, _), args) = + case t of + L'.TFun (dom, ran) => getArgs (ran, dom :: args) + | _ => (all, rev args) + + val (result, args) = getArgs (t, []) + val (isTransaction, result) = + case result of + (L'.CApp ((L'.CFfi ("Basis", "transaction"), _), + result), _) => (true, result) + | _ => (false, result) + + fun makeApp n = + let + val (actuals, _) = foldr (fn (t, (actuals, n)) => + (((L'.ERel n, loc), t) :: actuals, + n + 1)) ([], n) args + in + (L'.EFfiApp (m, x, actuals), loc) + end + val unit = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc) + val (result, app) = + if isTransaction then + ((L'.TFun (unit, result), loc), + (L'.EAbs ("_", + unit, + result, + makeApp 1), loc)) + else + (result, makeApp 0) + + val (abs, _, _) = foldr (fn (t, (abs, ran, n)) => + ((L'.EAbs ("arg" ^ Int.toString n, + t, + ran, + abs), loc), + (L'.TFun (t, ran), loc), + n - 1)) (app, result, length args - 1) args + in + abs + end + | _ => (L'.EFfi (m, x), loc) + end + | L.EApp (e1, e2) => (L'.EApp (corifyExp st e1, corifyExp st e2), loc) + | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, corifyCon st dom, corifyCon st ran, corifyExp st e1), loc) + | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc) + | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc) + | L.EKApp (e1, k) => (L'.EKApp (corifyExp st e1, corifyKind k), loc) + | L.EKAbs (x, e1) => (L'.EKAbs (x, corifyExp st e1), loc) + + | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => + (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) + | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, + {field = corifyCon st field, rest = corifyCon st rest}), loc) + | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (corifyExp st e1, corifyCon st c1, corifyExp st e2, + corifyCon st c2), loc) + | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c, + {field = corifyCon st field, rest = corifyCon st rest}), loc) + | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c, + {rest = corifyCon st rest}), loc) + + | L.ECase (e, pes, {disc, result}) => + (L'.ECase (corifyExp st e, + map (fn (p, e) => (corifyPat st p, corifyExp st e)) pes, + {disc = corifyCon st disc, result = corifyCon st result}), + loc) + + | L.EWrite e => (L'.EWrite (corifyExp st e), loc) + + | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc) + +fun isTransactional (c, _) = + case c of + L'.TFun (_, c) => isTransactional c + | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true + | _ => false + +fun corifyDecl mods (all as (d, loc : EM.span), st) = + case d of + L.DCon (x, n, k, c) => + let + val (st, n) = St.bindCon st x n + in + ([(L'.DCon (x, n, corifyKind k, corifyCon st c), loc)], st) + end + | L.DDatatype dts => + let + val (dts, st) = ListUtil.foldlMap (fn ((x, n, xs, xncs), st) => + let + val (st, n) = St.bindCon st x n + in + ((x, n, xs, xncs), st) + end) + st dts + + val (dts, (st, dcons)) = + ListUtil.foldlMap + (fn ((x, n, xs, xncs), (st, dcons)) => + let + val (xncs, st) = ListUtil.foldlMap + (fn ((x, n, co), st) => + let + val (st, n') = St.bindConstructor st x n + val st = St.bindConstructorVal st x n n' + val co = Option.map (corifyCon st) co + in + ((x, n', co), st) + end) st xncs + + val dk = ElabUtil.classifyDatatype xncs + val t = (L'.CNamed n, loc) + val nxs = length xs - 1 + val t = ListUtil.foldli + (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs + val k = (L'.KType, loc) + val dcons' = map (fn (x, n, to) => + let + val args = ListUtil.mapi + (fn (i, _) => (L'.CRel (nxs - i), loc)) xs + val (e, t) = + case to of + NONE => ((L'.ECon (dk, L'.PConVar n, args, NONE), + loc), t) + | SOME t' => ((L'.EAbs ("x", t', t, + (L'.ECon (dk, L'.PConVar n, + args, + SOME (L'.ERel 0, + loc)), + loc)), + loc), + (L'.TFun (t', t), loc)) + + val t = foldr (fn (x, t) => (L'.TCFun (x, k, t), loc)) t xs + val e = foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc)) e xs + in + (L'.DVal (x, n, t, e, ""), loc) + end) xncs + in + ((x, n, xs, xncs), (st, dcons' @ dcons)) + end) + (st, []) dts + in + ((L'.DDatatype dts, loc) :: dcons, st) + end + | L.DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + let + val (st, n) = St.bindCon st x n + val c = corifyCon st (L.CModProj (m1, ms, s), loc) + + val m = foldl (fn (x, m) => (L.StrProj (m, x), loc)) (L.StrVar m1, loc) ms + val (_, {inner, ...}) = corifyStr mods (m, st) + + val (xncs, st) = ListUtil.foldlMap (fn ((x, n, co), st) => + let + val n' = St.lookupConstructorByName inner x + val st = St.bindConstructorAs st x n n' + val (st, n) = St.bindVal st x n + val co = Option.map (corifyCon st) co + in + ((x, n, co), st) + end) st xncs + + val nxs = length xs - 1 + val cBase = c + val c = ListUtil.foldli (fn (i, _, c) => (L'.CApp (c, (L'.CRel (nxs - i), loc)), loc)) c xs + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + + val cds = map (fn (x, n, co) => + let + val t = case co of + NONE => c + | SOME t' => (L'.TFun (t', c), loc) + val e = corifyExp st (L.EModProj (m1, ms, x), loc) + + val t = foldr (fn (x, t) => (L'.TCFun (x, k, t), loc)) t xs + in + (L'.DVal (x, n, t, e, x), loc) + end) xncs + in + ((L'.DCon (x, n, k', cBase), loc) :: cds, st) + end + | L.DVal (x, n, t, e as (L.ENamed n', _)) => + let + val st = + case St.lookupConstructorByIdOpt st n' of + SOME pc => St.bindConstructorAs st x n pc + | _ => st + + val (st, n) = St.bindVal st x n + val s = doRestify Settings.Url (mods, x) + in + ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st) + end + | L.DVal (x, n, t, e) => + let + val (st, n) = St.bindVal st x n + val s = doRestify Settings.Url (mods, x) + in + ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st) + end + | L.DValRec vis => + let + val (vis, st) = ListUtil.foldlMap + (fn ((x, n, t, e), st) => + let + val (st, n) = St.bindVal st x n + in + ((x, n, t, e), st) + end) + st vis + + val vis = map + (fn (x, n, t, e) => + let + val s = doRestify Settings.Url (mods, x) + in + (x, n, corifyCon st t, corifyExp st e, s) + end) + vis + in + ([(L'.DValRec vis, loc)], st) + end + | L.DSgn _ => ([], st) + + | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => + ([], St.bindFunctor st x n xa na str) + + | L.DStr (x, n, _, (L.StrProj (str, x'), _)) => + let + val (ds, {inner, outer}) = corifyStr mods (str, st) + + val st = case St.lookupStrByNameOpt (x', inner) of + SOME st' => St.bindStr st x n st' + | NONE => + let + val (x', n', str') = St.lookupFunctorByName (x', inner) + in + St.bindFunctor st x n x' n' str' + end + in + ([], st) + end + + | L.DStr (x, n, _, (L.StrVar n', _)) => + (case St.lookupFunctorByIdOpt st n' of + SOME (arg, dom, body) => ([], St.bindFunctor st x n arg dom body) + | NONE => ([], St.bindStr st x n (St.lookupStrById st n'))) + + | L.DStr (x, n, _, str) => + let + val mods' = + if x = "anon" then + mods + else + x :: mods + + val (ds, {inner, outer}) = corifyStr mods' (str, st) + val st = St.bindStr outer x n inner + in + (ds, st) + end + + | L.DFfiStr (m, n, (sgn, _)) => + (case sgn of + L.SgnConst sgis => + let + val (ds, cmap, conmap, st, _) = + foldl (fn ((sgi, _), (ds, cmap, conmap, st, trans)) => + case sgi of + L.SgiConAbs (x, n, k) => + let + val (st, n') = St.bindCon st x n + + val trans = + if x = "transaction" then + SOME n + else + trans + in + ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, + cmap, + conmap, + st, + trans) + end + | L.SgiCon (x, n, k, _) => + let + val (st, n') = St.bindCon st x n + in + ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, + cmap, + conmap, + st, + trans) + end + + | L.SgiDatatype dts => + let + val k = (L'.KType, loc) + + val (dts, (ds', st, cmap, conmap)) = + ListUtil.foldlMap + (fn ((x, n, xs, xnts), (ds', st, cmap, conmap)) => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) + k xs + + val dk = ElabUtil.classifyDatatype xnts + val (st, n') = St.bindCon st x n + val (xnts, (ds', st, cmap, conmap)) = + ListUtil.foldlMap + (fn ((x', n, to), (ds', st, cmap, conmap)) => + let + val dt = (L'.CNamed n', loc) + val args = ListUtil.mapi (fn (i, _) => (L'.CRel i, loc)) xs + + val to = Option.map (corifyCon st) to + + val pc = L'.PConFfi {mod = m, + datatyp = x, + params = xs, + con = x', + arg = to, + kind = dk} + + fun wrapT t = + foldr (fn (x, t) => (L'.TCFun (x, k, t), loc)) + t xs + fun wrapE e = + foldr (fn (x, e) => (L'.ECAbs (x, k, e), loc)) + e xs + + val (cmap, d) = + case to of + NONE => (SM.insert (cmap, x', wrapT dt), + (L'.DVal (x', n, wrapT dt, + wrapE + (L'.ECon (dk, pc, + args, + NONE), + loc), + ""), loc)) + | SOME t => + let + val tf = (L'.TFun (t, dt), loc) + val e = wrapE + (L'.EAbs ("x", t, tf, + (L'.ECon (dk, + pc, + args, + SOME + (L'.ERel 0, + loc)), + loc)), loc) + val d = (L'.DVal (x', n, wrapT tf, + e, ""), loc) + in + (SM.insert (cmap, x', wrapT tf), d) + end + + val st = St.bindConstructorAs st x' n pc + + val conmap = SM.insert (conmap, x', + (x, xs, to, dk)) + in + ((x', n, to), + (d :: ds', st, cmap, conmap)) + end) (ds', st, cmap, conmap) xnts + + val d = (L'.DCon (x, n', k', (L'.CFfi (m, x), loc)), loc) + in + ((x, n', xs, xnts), (d :: ds', st, cmap, conmap)) + end) + ([], st, cmap, conmap) dts + in + (List.revAppend (ds', ds), + cmap, + conmap, + st, + trans) + end + + | L.SgiVal (x, _, c) => + let + val c = + case trans of + NONE => corifyCon st c + | SOME trans => + let + fun transactify (all as (c, loc)) = + case c of + L.TFun (dom, ran) => + (L'.TFun (corifyCon st dom, transactify ran), loc) + | L.CApp ((L.CNamed trans', _), t) => + if trans' = trans then + (L'.CApp ((L'.CFfi (m, "transaction"), loc), + corifyCon st t), loc) + else + corifyCon st all + | _ => corifyCon st all + in + transactify c + end + in + if isTransactional c then + let + val ffi = (m, x) + in + if Settings.isBenignEffectful ffi then + () + else + Settings.addEffectful ffi + end + else + (); + (ds, + SM.insert (cmap, x, c), + conmap, + st, + trans) + end + | _ => (ds, cmap, conmap, st, trans)) + ([], SM.empty, SM.empty, st, NONE) sgis + + val st = St.bindStr st m n (St.ffi m cmap conmap) + in + (rev ds, if m = "Basis" then St.basisIs (st, n) else st) + end + | _ => raise Fail "Non-const signature for FFI structure") + + | L.DExport (en, sgn, str) => + (case #1 sgn of + L.SgnConst sgis => + let + fun pathify (str, _) = + case str of + L.StrVar m => SOME (m, []) + | L.StrProj (str, s) => + Option.map (fn (m, ms) => (m, ms @ [s])) (pathify str) + | _ => NONE + in + case pathify str of + NONE => (ErrorMsg.errorAt loc "Structure is too fancy to export"; + ([], st)) + | SOME (m, ms) => + let + val basis_n = case St.lookupBasis st of + NONE => raise Fail "Corify: Don't know number of Basis" + | SOME n => n + + fun wrapSgi ((sgi, _), (wds, eds)) = + case sgi of + L.SgiVal (s, _, t) => + let + fun getPage (t, args) = + case #1 t of + L.CApp ((L.CModProj (basis, [], "transaction"), _), + t' as + (L.CApp + ((L.CApp + ((L.CApp ((L.CModProj (basis', [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), + _), _), _)) => + if basis = basis_n andalso basis' = basis_n then + SOME (t', rev args) + else + NONE + | L.TFun (dom, ran) => getPage (ran, dom :: args) + | _ => NONE + in + case getPage (t, []) of + NONE => (wds, eds) + | SOME (ran', args) => + let + val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) + val ranT = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc), + ran), loc) + val e = (L.EModProj (m, ms, s), loc) + + val ef = (L.EModProj (basis_n, [], "bind"), loc) + val ef = (L.ECApp (ef, (L.CModProj (basis_n, [], "transaction"), loc)), loc) + val ef = (L.ECApp (ef, ran'), loc) + val ef = (L.ECApp (ef, ran), loc) + val ef = (L.EApp (ef, (L.EModProj (basis_n, [], "transaction_monad"), loc)), + loc) + val ea = ListUtil.foldri (fn (i, _, ea) => + (L.EApp (ea, (L.ERel i, loc)), loc)) e args + val ef = (L.EApp (ef, ea), loc) + + val eat = (L.CApp ((L.CModProj (basis_n, [], "transaction"), loc), + ran), loc) + val ea = (L.EAbs ("p", ran', eat, + (L.EWrite (L.ERel 0, loc), loc)), loc) + + val (e, tf) = ListUtil.foldri (fn (i, t, (e, tf)) => + ((L.EAbs ("x" ^ Int.toString i, + t, tf, e), loc), + (L.TFun (t, tf), loc))) + ((L.EApp (ef, ea), loc), ranT) args + + val expKind = if List.exists (fn t => + case corifyCon st t of + (L'.CFfi ("Basis", "postBody"), _) => true + | _ => false) args then + L'.Extern L'.ReadCookieWrite + else + L'.Link L'.ReadCookieWrite + in + ((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds, + (fn st => + case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of + L'.ENamed n => (L'.DExport (expKind, n, false), loc) + | _ => raise Fail "Corify: Value to export didn't corify properly") + :: eds) + end + end + | _ => (wds, eds) + + val (wds, eds) = foldl wrapSgi ([], []) sgis + val wrapper = (L.StrConst wds, loc) + val mst = St.lookupStrById st m + val mst = foldl St.lookupStrByName mst ms + val (ds, {inner, outer}) = corifyStr (St.name mst) (wrapper, st) + val st = St.bindStr outer "wrapper" en inner + + val ds = ds @ map (fn f => f st) eds + in + (ds, st) + end + end + | _ => raise Fail "Non-const signature for 'export'") + + | L.DTable (_, x, n, c, pe, pc, ce, cc) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify Settings.Table (mods, x)) + in + ([(L'.DTable (x, n, corifyCon st c, s, + corifyExp st pe, corifyCon st pc, + corifyExp st ce, corifyCon st cc), loc)], st) + end + | L.DSequence (_, x, n) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify Settings.Sequence (mods, x)) + in + ([(L'.DSequence (x, n, s), loc)], st) + end + | L.DView (_, x, n, e, c) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify Settings.View (mods, x)) + in + ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st) + end + + | L.DDatabase s => ([(L'.DDatabase s, loc)], st) + + | L.DCookie (_, x, n, c) => + let + val (st, n) = St.bindVal st x n + val s = doRestify Settings.Cookie (mods, x) + in + ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) + end + | L.DStyle (_, x, n) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify Settings.Style (mods, x)) + in + ([(L'.DStyle (x, n, s), loc)], st) + end + + | L.DTask (e1, e2) => + ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st) + + | L.DPolicy e1 => + ([(L'.DPolicy (corifyExp st e1), loc)], st) + + | L.DOnError (m, ms, x) => + let + val st = St.lookupStrById st m + val st = foldl St.lookupStrByName st ms + in + case St.lookupValByName st x of + St.ENormal n => ([(L'.DOnError n, loc)], st) + | _ => (ErrorMsg.errorAt loc "Wrong type of identifier for 'onError'"; + ([], st)) + end + + | L.DFfi (x, n, modes, t) => + let + val m = case St.name st of + [m] => m + | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level"; + "") + + val name = (m, x) + + val (st, n) = St.bindVal st x n + val s = doRestify Settings.Url (mods, x) + + val t' = corifyCon st t + + fun numArgs (t : L'.con) = + case #1 t of + L'.TFun (_, ran) => 1 + numArgs ran + | _ => 0 + + fun makeArgs (i, t : L'.con, acc) = + case #1 t of + L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc) + | _ => rev acc + + fun wrapAbs (i, t : L'.con, tTrans, e) = + case (#1 t, #1 tTrans) of + (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc) + | _ => e + + fun getRan (t : L'.con) = + case #1 t of + L'.TFun (_, ran) => getRan ran + | _ => t + + fun addLastBit (t : L'.con) = + case #1 t of + L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t) + | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc) + + val isTrans = isTransactional t' + val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - + (if isTrans then + 0 + else + 1), t', [])), loc) + val (e, tTrans) = if isTrans then + ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t') + else + (e, t') + val e = wrapAbs (0, t', tTrans, e) + in + app (fn Source.Effectful => Settings.addEffectful name + | Source.BenignEffectful => Settings.addBenignEffectful name + | Source.ClientOnly => Settings.addClientOnly name + | Source.ServerOnly => Settings.addServerOnly name + | Source.JsFunc s => Settings.addJsFunc (name, s)) modes; + + if List.exists (fn Source.JsFunc _ => true | _ => false) modes then + () + else + Settings.addJsFunc (name, #2 name); + + if isTrans andalso not (Settings.isBenignEffectful name) then + Settings.addEffectful name + else + (); + + ([(L'.DVal (x, n, t', e, s), loc)], st) + end + +and corifyStr mods ((str, loc), st) = + case str of + L.StrConst ds => + let + val st = St.enter (st, mods) + val (ds, st) = ListUtil.foldlMapConcat (corifyDecl mods) st ds + in + (ds, St.leave st) + end + | L.StrVar n => ([], {inner = St.lookupStrById st n, outer = st}) + | L.StrProj (str, x) => + let + val (ds, {inner, outer}) = corifyStr mods (str, st) + in + (ds, {inner = St.lookupStrByName (x, inner), outer = outer}) + end + | L.StrFun _ => raise Fail "Corify of nested functor definition" + | L.StrApp (str1, str2) => + let + fun unwind' (str, _) = + case str of + L.StrVar n => St.lookupStrById st n + | L.StrProj (str, x) => St.lookupStrByName (x, unwind' str) + | _ => raise Fail "Corify of fancy functor application [1]" + + fun unwind (str, _) = + case str of + L.StrVar n => St.lookupFunctorById st n + | L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str) + | _ => raise Fail "Corify of fancy functor application [2]" + + val (xa, na, body) = unwind str1 + + (* An important step to make sure that nested functors + * "close under their environments": *) + val (next, body') = ExplRename.rename {NextId = getCounter (), + FormalName = xa, + FormalId = na, + Body = body} + + (*val () = Print.prefaces ("RENAME " ^ ErrorMsg.spanToString loc) + [("FROM", ExplPrint.p_str ExplEnv.empty body), + ("TO", ExplPrint.p_str ExplEnv.empty body')]*) + val body = body' + + val () = setCounter next + + val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st) + + val (ds2, {inner, outer}) = corifyStr mods (body, St.bindStr outer xa na inner') + in + (ds1 @ ds2, {inner = St.bindStr inner xa na inner', outer = outer}) + end + +fun maxName ds = foldl (fn ((d, _), n) => + case d of + L.DCon (_, n', _, _) => Int.max (n, n') + | L.DDatatype dts => foldl (fn ((_, n', _, _), n) => Int.max (n, n')) n dts + | L.DDatatypeImp (_, n', _, _, _, _, _) => Int.max (n, n') + | L.DVal (_, n', _, _) => Int.max (n, n') + | L.DValRec vis => foldl (fn ((_, n', _, _), n) => Int.max (n, n)) n vis + | L.DSgn (_, n', _) => Int.max (n, n') + | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str)) + | L.DFfiStr (_, n', _) => Int.max (n, n') + | L.DExport _ => n + | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') + | L.DSequence (_, _, n') => Int.max (n, n') + | L.DView (_, _, n', _, _) => Int.max (n, n') + | L.DDatabase _ => n + | L.DCookie (_, _, n', _) => Int.max (n, n') + | L.DStyle (_, _, n') => Int.max (n, n') + | L.DTask _ => n + | L.DPolicy _ => n + | L.DOnError _ => n + | L.DFfi (_, n', _, _) => Int.max (n, n')) + 0 ds + +and maxNameStr (str, _) = + case str of + L.StrConst ds => maxName ds + | L.StrVar n => n + | L.StrProj (str, _) => maxNameStr str + | L.StrFun (_, _, _, _, str) => maxNameStr str + | L.StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2) + +fun corify ds = + let + val () = reset (maxName ds + 1) + + val (ds, _) = ListUtil.foldlMapConcat (corifyDecl []) St.empty ds + in + ds + end + +end diff --git a/src/css.sig b/src/css.sig new file mode 100644 index 0000000..c7243cf --- /dev/null +++ b/src/css.sig @@ -0,0 +1,43 @@ +(* Copyright (c) 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. + *) + +signature CSS = sig + + datatype inheritable = Block | List | Table | Caption | Td + datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height + + val inheritableToString : inheritable -> string + val othersToString : others -> string + + type summary = inheritable list * others list + + type report = {Overall : inheritable list, + Classes : (string * summary) list} + + val summarize : Core.file -> report + +end diff --git a/src/css.sml b/src/css.sml new file mode 100644 index 0000000..9e50686 --- /dev/null +++ b/src/css.sml @@ -0,0 +1,320 @@ +(* Copyright (c) 2010, 2013, 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 Css :> CSS = struct + +structure IM = IntBinaryMap + +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +datatype inheritable = Block | List | Table | Caption | Td +datatype others = OBlock | OTable | OTd | Tr | NonReplacedInline | ReplacedInline | Width | Height + +fun inheritableToString x = + case x of + Block => "B" + | List => "L" + | Table => "T" + | Caption => "C" + | Td => "D" + +fun othersToString x = + case x of + OBlock => "b" + | OTable => "t" + | OTd => "d" + | Tr => "-" + | NonReplacedInline => "N" + | ReplacedInline => "R" + | Width => "W" + | Height => "H" + +type summary = inheritable list * others list + +fun merge' (ls1, ls2) = foldl (fn (x, ls) => if List.exists (fn y => y = x) ls then ls else x :: ls) ls2 ls1 +fun merge ((in1, ot1), (in2, ot2)) = (merge' (in1, in2), merge' (ot1, ot2)) +fun mergePC {parent = (in1, ot1), child = in2} = (merge' (in1, in2), ot1) + +val nada = ([], []) +val block = ([Block], [OBlock, Width, Height]) +val inline = ([], [NonReplacedInline]) +val list = ([Block, List], [OBlock, Width, Height]) +val replaced = ([], [ReplacedInline, Width, Height]) +val table = ([Block, Table], [OBlock, OTable, Width, Height]) +val tr = ([Block], [OBlock, Tr, Height]) +val td = ([Block, Td], [OBlock, OTd, Width]) + +val tags = [("span", inline), + ("div", block), + ("p", block), + ("b", inline), + ("i", inline), + ("tt", inline), + ("h1", block), + ("h2", block), + ("h3", block), + ("h4", block), + ("h5", block), + ("h6", block), + ("li", list), + ("ol", list), + ("ul", list), + ("hr", block), + ("a", inline), + ("img", replaced), + ("form", block), + ("hidden", replaced), + ("textbox", replaced), + ("password", replaced), + ("textarea", replaced), + ("checkbox", replaced), + ("upload", replaced), + ("radio", replaced), + ("select", replaced), + ("submit", replaced), + ("label", inline), + ("ctextbox", replaced), + ("cpassword", replaced), + ("button", replaced), + ("ccheckbox", replaced), + ("cselect", replaced), + ("ctextarea", replaced), + ("tabl", table), + ("tr", tr), + ("th", td), + ("td", td)] + +val tags = foldl (fn ((tag, css), tags) => + SM.insert (tags, tag, css)) SM.empty tags + +open Core + +fun summarize file = + let + fun decl ((d, _), st as (globals, classes)) = + let + fun getTag (e, _) = + case e of + EFfi ("Basis", tag) => SOME tag + | ECApp (e, _) => getTag e + | EApp (e, _) => getTag e + | _ => NONE + + fun exp ((e, _), classes) = + case e of + EPrim _ => ([], classes) + | ERel _ => ([], classes) + | ENamed n => + (case IM.find (globals, n) of + NONE => [] + | SOME (_, sm) => sm, + classes) + | ECon (_, _, _, NONE) => ([], classes) + | ECon (_, _, _, SOME e) => exp (e, classes) + | EFfi _ => ([], classes) + | EFfiApp (_, _, es) => expList (map #1 es, classes) + + | EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + (ENamed class, _)), _), + _), _), + _), _), + _), _), + attrs), _), + tag), _), + xml) => + let + val (sm, classes) = exp (xml, classes) + val (sm', classes) = exp (attrs, classes) + val sm = merge' (sm, sm') + in + case getTag tag of + NONE => (sm, classes) + | SOME tag => + case SM.find (tags, tag) of + NONE => (sm, classes) + | SOME sm' => + let + val sm'' = mergePC {parent = sm', child = sm} + val old = Option.getOpt (IM.find (classes, class), nada) + val classes = IM.insert (classes, class, merge (old, sm'')) + in + (merge' (#1 sm', sm), classes) + end + end + + | EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), _), + _), _), + _), _), + _), _), + attrs), _), + tag), _), + xml) => + let + val (sm, classes) = exp (xml, classes) + val (sm', classes) = exp (attrs, classes) + val sm = merge' (sm, sm') + in + case getTag tag of + NONE => (sm, classes) + | SOME tag => + case SM.find (tags, tag) of + NONE => (sm, classes) + | SOME sm' => (merge' (#1 sm', sm), classes) + end + + | EApp (e1, e2) => + let + val (sm1, classes) = exp (e1, classes) + val (sm2, classes) = exp (e2, classes) + in + (merge' (sm1, sm2), classes) + end + | EAbs (_, _, _, e) => exp (e, classes) + | ECApp (e, _) => exp (e, classes) + | ECAbs (_, _, e) => exp (e, classes) + | EKAbs (_, e) => exp (e, classes) + | EKApp (e, _) => exp (e, classes) + | ERecord xets => expList (map #2 xets, classes) + | EField (e, _, _) => exp (e, classes) + | EConcat (e1, _, e2, _) => + let + val (sm1, classes) = exp (e1, classes) + val (sm2, classes) = exp (e2, classes) + in + (merge' (sm1, sm2), classes) + end + | ECut (e, _, _) => exp (e, classes) + | ECutMulti (e, _, _) => exp (e, classes) + | ECase (e, pes, _) => + let + val (sm, classes) = exp (e, classes) + val (sms, classes) = expList (map #2 pes, classes) + in + (merge' (sm, sms), classes) + end + | EWrite e => exp (e, classes) + | EClosure (_, es) => expList (es, classes) + | ELet (_, _, e1, e2) => + let + val (sm1, classes) = exp (e1, classes) + val (sm2, classes) = exp (e2, classes) + in + (merge' (sm1, sm2), classes) + end + | EServerCall (_, es, _, _) => expList (es, classes) + + and expList (es, classes) = foldl (fn (e, (sm, classes)) => + let + val (sm', classes) = exp (e, classes) + in + (merge' (sm, sm'), classes) + end) ([], classes) es + in + case d of + DCon _ => st + | DDatatype _ => st + | DVal (_, n, _, e, _) => + let + val (sm, classes) = exp (e, classes) + in + (IM.insert (globals, n, (NONE, sm)), classes) + end + | DValRec vis => + let + val (sm, classes) = foldl (fn ((_, _, _, e, _), + (sm, classes)) => + let + val (sm', classes) = exp (e, classes) + in + (merge' (sm', sm), classes) + end) ([], classes) vis + in + (foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, (NONE, sm))) globals vis, + classes) + end + | DExport _ => st + | DTable _ => st + | DSequence _ => st + | DView _ => st + | DDatabase _ => st + | DCookie _ => st + | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes) + | DTask _ => st + | DPolicy _ => st + | DOnError _ => st + end + + val (globals, classes) = foldl decl (IM.empty, IM.empty) file + in + {Overall = IM.foldl (fn ((_, sm), sm') => merge' (sm, sm')) [] globals, + Classes = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) + (List.mapPartial (fn (i, sm) => + case IM.find (globals, i) of + SOME (SOME s, _) => SOME (s, sm) + | _ => NONE) (IM.listItemsi classes))} + end + +type report = {Overall : inheritable list, + Classes : (string * summary) list} + +end diff --git a/src/datatype_kind.sml b/src/datatype_kind.sml new file mode 100644 index 0000000..140a012 --- /dev/null +++ b/src/datatype_kind.sml @@ -0,0 +1,35 @@ +(* Copyright (c) 2009, 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 DatatypeKind = struct + +datatype datatype_kind = + Enum + | Option + | Default + +end diff --git a/src/dbmodecheck.sig b/src/dbmodecheck.sig new file mode 100644 index 0000000..4d4873c --- /dev/null +++ b/src/dbmodecheck.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2014, 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 DB_MODE_CHECK = sig + + val classify : Mono.file -> Mono.file + +end diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml new file mode 100644 index 0000000..eb416ce --- /dev/null +++ b/src/dbmodecheck.sml @@ -0,0 +1,86 @@ +(* Copyright (c) 2014, 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 DbModeCheck :> DB_MODE_CHECK = struct + +open Mono + +structure IM = IntBinaryMap + +fun classify (ds, ps) = + let + fun mergeModes (m1, m2) = + case (m1, m2) of + (NoDb, _) => m2 + | (_, NoDb) => m1 + | _ => AnyDb + + fun modeOf modes = + MonoUtil.Exp.fold {typ = fn (_, dbm) => dbm, + exp = fn (EQuery _, dbm) => mergeModes (OneQuery, dbm) + | (EDml _, _) => AnyDb + | (ENextval _, _) => AnyDb + | (ESetval _, _) => AnyDb + | (ENamed n, dbm) => + (case IM.find (modes, n) of + NONE => dbm + | SOME dbm' => mergeModes (dbm, dbm')) + | (_, dbm) => dbm} NoDb + + fun decl ((d, _), modes) = + case d of + DVal (x, n, _, e, _) => IM.insert (modes, n, modeOf modes e) + | DValRec xes => + let + val mode = foldl (fn ((_, _, _, e, _), mode) => + let + val mode' = modeOf modes e + in + case mode' of + NoDb => mode + | _ => AnyDb + end) NoDb xes + in + foldl (fn ((_, n, _, _, _), modes) => IM.insert (modes, n, mode)) modes xes + end + | _ => modes + + val modes = foldl decl IM.empty ds + + val (ps, modes) = ListUtil.foldlMap (fn ((n, side, _), modes) => + case IM.find (modes, n) of + NONE => ((n, side, AnyDb), modes) + | SOME mode => ((n, side, mode), #1 (IM.remove (modes, n)))) + modes ps + + val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes + in + (ds, ps) + end + +end + diff --git a/src/demo.sig b/src/demo.sig new file mode 100644 index 0000000..57154ed --- /dev/null +++ b/src/demo.sig @@ -0,0 +1,35 @@ +(* Copyright (c) 2008, 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 DEMO = sig + + val make : {prefix : string, dirname : string, guided : bool} -> unit + val make' : {prefix : string, dirname : string, guided : bool} -> bool + + val noEmacs : bool ref + +end diff --git a/src/demo.sml b/src/demo.sml new file mode 100644 index 0000000..62b9037 --- /dev/null +++ b/src/demo.sml @@ -0,0 +1,477 @@ +(* 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 Demo :> DEMO = struct + +val noEmacs = ref false + +fun make' {prefix, dirname, guided} = + let + val prose = OS.Path.joinDirFile {dir = dirname, + file = "prose"} + val inf = FileIO.txtOpenIn prose + + val outDir = OS.Path.concat (dirname, "out") + + val () = if OS.FileSys.access (outDir, []) then + () + else + OS.FileSys.mkDir outDir + + val fname = OS.Path.joinDirFile {dir = outDir, + file = "index.html"} + + val out = TextIO.openOut fname + val () = (TextIO.output (out, "<frameset cols=\"15%,85%\">\n"); + TextIO.output (out, "<frame src=\"demos.html\">\n"); + TextIO.output (out, "<frame src=\"intro.html\" name=\"staging\">\n"); + TextIO.output (out, "</frameset>\n"); + TextIO.closeOut out) + + val fname = OS.Path.joinDirFile {dir = outDir, + file = "demos.html"} + + val demosOut = TextIO.openOut fname + val () = (TextIO.output (demosOut, "<html><body>\n\n"); + TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"intro.html\">Intro</a></li>\n\n")) + + val fname = OS.Path.joinDirFile {dir = dirname, + file = "demo.urs"} + val ursOut = TextIO.openOut fname + val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n"); + TextIO.closeOut ursOut) + + val fname = OS.Path.joinDirFile {dir = dirname, + file = "demo.ur"} + val urOut = TextIO.openOut fname + val () = TextIO.output (urOut, "fun main () = return <xml><body>\n") + + fun mergeWith f (o1, o2) = + case (o1, o2) of + (NONE, _) => o2 + | (_, NONE) => o1 + | (SOME v1, SOME v2) => SOME (f (v1, v2)) + + fun combiner (combined : Compiler.job, urp : Compiler.job) = { + prefix = prefix, + database = mergeWith (fn (v1, v2) => + if v1 = v2 then + v1 + else + raise Fail "Different demos want to use different database strings") + (#database combined, #database urp), + sources = foldl (fn (file, files) => + if List.exists (fn x => x = file) files then + files + else + files @ [file]) + (#sources combined) (#sources urp), + exe = case Settings.getExe () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo.exe"} + | SOME s => s, + sql = SOME (case Settings.getSql () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo.sql"} + | SOME s => s), + debug = Settings.getDebug (), + timeout = Int.max (#timeout combined, #timeout urp), + profile = false, + ffi = [], + link = [], + linker = NONE, + headers = [], + scripts = [], + clientToServer = [], + effectful = [], + benignEffectful = [], + clientOnly = [], + serverOnly = [], + jsModule = NONE, + jsFuncs = [], + rewrites = #rewrites combined @ #rewrites urp, + filterUrl = #filterUrl combined @ #filterUrl urp, + filterMime = #filterMime combined @ #filterMime urp, + filterRequest = #filterRequest combined @ #filterRequest urp, + filterResponse = #filterResponse combined @ #filterResponse urp, + filterEnv = #filterEnv combined @ #filterEnv urp, + filterMeta = #filterMeta combined @ #filterMeta urp, + protocol = mergeWith #2 (#protocol combined, #protocol urp), + dbms = mergeWith #2 (#dbms combined, #dbms urp), + sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), + safeGets = #safeGets combined @ #safeGets urp, + onError = NONE, + minHeap = 0 + } + + val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") + + fun capitalize "" = "" + | capitalize s = str (Char.toUpper (String.sub (s, 0))) + ^ String.extract (s, 1, NONE) + + fun startUrp urp = + let + val base = OS.Path.base urp + val name = capitalize base + + val () = (TextIO.output (demosOut, "<li> <a target=\"staging\" href=\""); + TextIO.output (demosOut, base); + TextIO.output (demosOut, ".html\">"); + TextIO.output (demosOut, name); + TextIO.output (demosOut, "</a></li>\n")) + + val () = (TextIO.output (urOut, " <li> <a link={"); + TextIO.output (urOut, name); + TextIO.output (urOut, ".main ()}>"); + TextIO.output (urOut, name); + TextIO.output (urOut, "</a></li>\n")) + + val urp_file = OS.Path.joinDirFile {dir = dirname, + file = urp} + + val out = OS.Path.joinBaseExt {base = base, + ext = SOME "html"} + val out = OS.Path.joinDirFile {dir = outDir, + file = out} + val out = TextIO.openOut out + + val () = (TextIO.output (out, "<frameset rows=\""); + TextIO.output (out, if guided then + "*,100" + else + "50%,*"); + TextIO.output (out, "\">\n"); + TextIO.output (out, "<frame src=\""); + TextIO.output (out, prefix); + TextIO.output (out, "/"); + TextIO.output (out, name); + TextIO.output (out, "/main\" name=\"showcase\">\n"); + TextIO.output (out, "<frame src=\""); + TextIO.output (out, base); + TextIO.output (out, ".desc.html\">\n"); + TextIO.output (out, "</frameset>\n"); + TextIO.closeOut out) + val () = TextIO.closeOut out + + val out = OS.Path.joinBaseExt {base = base, + ext = SOME "desc"} + val out = OS.Path.joinBaseExt {base = out, + ext = SOME "html"} + val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir, + file = out}) + in + case parse (OS.Path.base urp_file) of + NONE => raise Fail ("Can't parse " ^ urp_file) + | SOME urpData => + (TextIO.output (out, "<html><head>\n<title>"); + TextIO.output (out, name); + TextIO.output (out, "</title>\n</head><body>\n\n<h1>"); + TextIO.output (out, name); + TextIO.output (out, "</h1>\n\n<center>[ <a target=\"showcase\" href=\""); + TextIO.output (out, prefix); + TextIO.output (out, "/"); + TextIO.output (out, name); + TextIO.output (out, "/main\">Application</a>"); + TextIO.output (out, " | <a target=\"showcase\" href=\""); + TextIO.output (out, urp); + TextIO.output (out, ".html\"><tt>"); + TextIO.output (out, urp); + TextIO.output (out, "</tt></a>"); + app (fn file => + let + fun ifEx s = + let + val src = OS.Path.joinBaseExt {base = file, + ext = SOME s} + val src' = OS.Path.file src + in + if String.isPrefix (OS.Path.mkAbsolute {path = dirname, + relativeTo = OS.FileSys.getDir ()}) src + andalso OS.FileSys.access (src, []) then + (TextIO.output (out, " | <a target=\"showcase\" href=\""); + TextIO.output (out, src'); + TextIO.output (out, ".html\"><tt>"); + TextIO.output (out, src'); + TextIO.output (out, "</tt></a>")) + else + () + end + in + ifEx "urs"; + ifEx "ur" + end) (#sources urpData); + TextIO.output (out, " ]</center>\n\n"); + + (urpData, out)) + end + + fun endUrp out = + (TextIO.output (out, "\n</body></html>\n"); + TextIO.closeOut out) + + fun readUrp (combined, out) = + let + fun finished () = endUrp out + + fun readUrp' () = + case TextIO.inputLine inf of + NONE => (finished (); + combined) + | SOME line => + if String.isSuffix ".urp\n" line then + let + val urp = String.substring (line, 0, size line - 1) + val (urpData, out) = startUrp urp + in + finished (); + + readUrp (combiner (combined, urpData), + out) + end + else + (TextIO.output (out, line); + readUrp' ()) + in + readUrp' () + end + + val indexFile = OS.Path.joinDirFile {dir = outDir, + file = "intro.html"} + + val out = TextIO.openOut indexFile + val () = TextIO.output (out, "<html><head>\n<title>Ur/Web Demo</title>\n</head><body>\n\n") + + fun readIndex () = + let + fun finished () = (TextIO.output (out, "\n</body></html>\n"); + TextIO.closeOut out) + in + case TextIO.inputLine inf of + NONE => (finished (); + NONE) + | SOME line => + if String.isSuffix ".urp\n" line then + let + val urp = String.substring (line, 0, size line - 1) + val (urpData, out) = startUrp urp + in + finished (); + + SOME (readUrp (urpData, + out)) + end + else + (TextIO.output (out, line); + readIndex ()) + end + + fun prettyPrint () = + let + val dir = Posix.FileSys.opendir dirname + + fun loop () = + case Posix.FileSys.readdir dir of + NONE => Posix.FileSys.closedir dir + | SOME file => + let + fun doit f = + f (OS.Path.joinDirFile {dir = dirname, + file = file}, + OS.Path.mkAbsolute + {relativeTo = OS.FileSys.getDir (), + path = OS.Path.joinDirFile {dir = outDir, + file = OS.Path.joinBaseExt {base = file, + ext = SOME "html"}}}) + + fun highlight () = + doit (fn (src, html) => + let + val dirty = + let + val srcSt = Posix.FileSys.stat src + val htmlSt = Posix.FileSys.stat html + in + Time.> (Posix.FileSys.ST.mtime srcSt, + Posix.FileSys.ST.mtime htmlSt) + end handle OS.SysErr _ => true + + val cmd = "emacs -no-init-file --eval \"(progn " + ^ "(global-font-lock-mode t) " + ^ "(add-to-list 'load-path \\\"" + ^ !Settings.configSitelisp + ^ "/\\\") " + ^ "(load \\\"urweb-mode-startup\\\") " + ^ "(load \\\"htmlize\\\") " + ^ "(urweb-mode) " + ^ "(find-file \\\"" + ^ src + ^ "\\\") " + ^ "(switch-to-buffer (htmlize-buffer)) " + ^ "(write-file \\\"" + ^ html + ^ "\\\") " + ^ "(kill-emacs))\"" + in + if dirty then + (print (">>> " ^ cmd ^ "\n"); + ignore (OS.Process.system cmd)) + else + () + end) + + val highlight = fn () => if !noEmacs then () else highlight () + in + if OS.Path.base file = "demo" then + () + else case OS.Path.ext file of + SOME "urp" => + doit (fn (src, html) => + let + val inf = FileIO.txtOpenIn src + val out = TextIO.openOut html + + fun loop () = + case TextIO.inputLine inf of + NONE => () + | SOME line => (TextIO.output (out, line); + loop ()) + in + TextIO.output (out, "<html><body>\n\n<pre>"); + loop (); + TextIO.output (out, "</pre>\n\n</body></html>"); + + TextIO.closeIn inf; + TextIO.closeOut out + end) + | SOME "urs" => highlight () + | SOME "ur" => highlight () + | _ => (); + loop () + end + in + loop () + end + in + case readIndex () of + NONE => raise Fail "No demo applications!" + | SOME combined => + let + val () = (TextIO.output (urOut, "</body></xml>\n"); + TextIO.closeOut urOut) + + val fname = OS.Path.joinDirFile {dir = dirname, + file = "demo.urp"} + val outf = TextIO.openOut fname + + fun filters kind = + app (fn rule : Settings.rule => + (TextIO.output (outf, case #action rule of + Settings.Allow => "allow" + | Settings.Deny => "deny"); + TextIO.output (outf, " "); + TextIO.output (outf, kind); + TextIO.output (outf, " "); + TextIO.output (outf, #pattern rule); + case #kind rule of + Settings.Exact => () + | Settings.Prefix => TextIO.output (outf, "*"); + TextIO.output (outf, "\n"))) + in + Option.app (fn db => (TextIO.output (outf, "database "); + TextIO.output (outf, db); + TextIO.output (outf, "\n"))) + (#database combined); + TextIO.output (outf, "sql demo.sql\n"); + TextIO.output (outf, "prefix "); + TextIO.output (outf, prefix); + TextIO.output (outf, "\n"); + app (fn rule => + (TextIO.output (outf, "rewrite "); + TextIO.output (outf, case #pkind rule of + Settings.Any => "all" + | Settings.Url => "url" + | Settings.Table => "table" + | Settings.Sequence => "sequence" + | Settings.View => "view" + | Settings.Relation => "relation" + | Settings.Cookie => "cookie" + | Settings.Style => "style"); + TextIO.output (outf, " "); + TextIO.output (outf, #from rule); + case #kind rule of + Settings.Exact => () + | Settings.Prefix => TextIO.output (outf, "*"); + TextIO.output (outf, " "); + TextIO.output (outf, #to rule); + if #hyphenate rule then + TextIO.output (outf, " [-]") + else + (); + TextIO.output (outf, "\n"))) (#rewrites combined); + filters "url" (#filterUrl combined); + filters "mime" (#filterMime combined); + app (fn path => + (TextIO.output (outf, "safeGet "); + TextIO.output (outf, path); + TextIO.output (outf, "\n"))) (#safeGets combined); + TextIO.output (outf, "\n"); + + app (fn s => + let + val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (), + path = s} + in + TextIO.output (outf, s); + TextIO.output (outf, "\n") + end) + (#sources combined); + TextIO.output (outf, "\n"); + TextIO.output (outf, "demo\n"); + + TextIO.closeOut outf; + + let + val b = Compiler.compile (OS.Path.base fname) + in + TextIO.output (demosOut, "\n</body></html>\n"); + TextIO.closeOut demosOut; + if b then + prettyPrint () + else + (); + b + end + end + end + +fun make args = if make' args then + () + else + OS.Process.exit OS.Process.failure + +end diff --git a/src/disjoint.sig b/src/disjoint.sig new file mode 100644 index 0000000..7ca05fd --- /dev/null +++ b/src/disjoint.sig @@ -0,0 +1,46 @@ +(* Copyright (c) 2008, 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 DISJOINT = sig + + type env + + val empty : env + val enter : env -> env + + type goal = ErrorMsg.span * ElabEnv.env * env * Elab.con * Elab.con + + val assert : ElabEnv.env -> env -> Elab.con * Elab.con -> env + + val prove : ElabEnv.env -> env -> Elab.con * Elab.con * ErrorMsg.span -> goal list + + val p_env : env -> unit + + val proved : int ref + val reset : unit -> unit + +end diff --git a/src/disjoint.sml b/src/disjoint.sml new file mode 100644 index 0000000..8fa8834 --- /dev/null +++ b/src/disjoint.sml @@ -0,0 +1,285 @@ +(* Copyright (c) 2008, 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 Disjoint :> DISJOINT = struct + +open Elab +open ElabOps + +datatype piece_fst = + NameC of string + | NameR of int + | NameN of int + | NameM of int * string list * string + | RowR of int + | RowN of int + | RowM of int * string list * string + +type piece = piece_fst * int list + +fun p2s p = + case p of + NameC s => "NameC(" ^ s ^ ")" + | NameR n => "NameR(" ^ Int.toString n ^ ")" + | NameN n => "NameN(" ^ Int.toString n ^ ")" + | NameM (n, _, s) => "NameR(" ^ Int.toString n ^ ", " ^ s ^ ")" + | RowR n => "RowR(" ^ Int.toString n ^ ")" + | RowN n => "RowN(" ^ Int.toString n ^ ")" + | RowM (n, _, s) => "RowR(" ^ Int.toString n ^ ", " ^ s ^ ")" + +fun pp p = print (p2s p ^ "\n") + +fun rp2s (p, ns) = String.concatWith " " (p2s p :: map Int.toString ns) + +structure PK = struct + +type ord_key = piece + +open Order + +fun compare' (p1, p2) = + case (p1, p2) of + (NameC s1, NameC s2) => String.compare (s1, s2) + | (NameR n1, NameR n2) => Int.compare (n1, n2) + | (NameN n1, NameN n2) => Int.compare (n1, n2) + | (NameM (n1, ss1, s1), NameM (n2, ss2, s2)) => + join (Int.compare (n1, n2), + fn () => join (String.compare (s1, s2), fn () => + joinL String.compare (ss1, ss2))) + | (RowR n1, RowR n2) => Int.compare (n1, n2) + | (RowN n1, RowN n2) => Int.compare (n1, n2) + | (RowM (n1, ss1, s1), RowM (n2, ss2, s2)) => + join (Int.compare (n1, n2), + fn () => join (String.compare (s1, s2), fn () => + joinL String.compare (ss1, ss2))) + + | (NameC _, _) => LESS + | (_, NameC _) => GREATER + + | (NameR _, _) => LESS + | (_, NameR _) => GREATER + + | (NameN _, _) => LESS + | (_, NameN _) => GREATER + + | (NameM _, _) => LESS + | (_, NameM _) => GREATER + + | (RowR _, _) => LESS + | (_, RowR _) => GREATER + + | (RowN _, _) => LESS + | (_, RowN _) => GREATER + +fun compare ((p1, ns1), (p2, ns2)) = + join (compare' (p1, p2), + fn () => joinL Int.compare (ns1, ns2)) + +end + +structure PS = BinarySetFn(PK) +structure PM = BinaryMapFn(PK) + +type env = PS.set PM.map + +fun p_env x = + (print "\nDENV:\n"; + PM.appi (fn (p1, ps) => + PS.app (fn p2 => + print (rp2s p1 ^ " ~ " ^ rp2s p2 ^ "\n")) ps) x) + +structure E = ElabEnv + +type goal = ErrorMsg.span * E.env * env * Elab.con * Elab.con + +val empty = PM.empty + +fun nameToRow (c, loc) = + (CRecord ((KUnit, loc), [((c, loc), (CUnit, loc))]), loc) + +fun pieceToRow' (p, loc) = + case p of + NameC s => nameToRow (CName s, loc) + | NameR n => nameToRow (CRel n, loc) + | NameN n => nameToRow (CNamed n, loc) + | NameM (n, xs, x) => nameToRow (CModProj (n, xs, x), loc) + | RowR n => (CRel n, loc) + | RowN n => (CNamed n, loc) + | RowM (n, xs, x) => (CModProj (n, xs, x), loc) + +fun pieceToRow ((p, ns), loc) = + foldl (fn (n, c) => (CProj (c, n), loc)) (pieceToRow' (p, loc)) ns + +datatype piece' = + Piece of piece + | Unknown of con + +fun pieceEnter' p = + case p of + NameR n => NameR (n + 1) + | RowR n => RowR (n + 1) + | _ => p + +fun pieceEnter (p, n) = (pieceEnter' p, n) + +fun enter denv = + PM.foldli (fn (p, pset, denv') => + PM.insert (denv', pieceEnter p, PS.map pieceEnter pset)) + PM.empty denv + +val lowercase = CharVector.map Char.toLower + +fun prove1 denv (p1, p2) = + case (p1, p2) of + ((NameC s1, _), (NameC s2, _)) => lowercase s1 <> lowercase s2 + | _ => + case PM.find (denv, p1) of + NONE => false + | SOME pset => PS.member (pset, p2) + +val proved = ref 0 +fun reset () = (ElabOps.reset (); + proved := 0) + +fun decomposeRow env c = + let + val loc = #2 c + + fun decomposeProj c = + let + val c = hnormCon env c + in + case #1 c of + CProj (c, n) => + let + val (c', ns) = decomposeProj c + in + (c', ns @ [n]) + end + | _ => (c, []) + end + + fun decomposeName (c, acc) = + let + val (cAll as (c, _), ns) = decomposeProj c + in + case c of + CName s => Piece (NameC s, ns) :: acc + | CRel n => Piece (NameR n, ns) :: acc + | CNamed n => Piece (NameN n, ns) :: acc + | CModProj (m1, ms, x) => Piece (NameM (m1, ms, x), ns) :: acc + | _ => Unknown cAll :: acc + end + + fun decomposeRow' (c, acc) = + let + fun default () = + let + val (cAll as (c, _), ns) = decomposeProj c + in + case c of + CRecord (_, xcs) => foldl (fn ((x, _), acc) => decomposeName (x, acc)) acc xcs + | CConcat (c1, c2) => decomposeRow' (c1, decomposeRow' (c2, acc)) + | CRel n => Piece (RowR n, ns) :: acc + | CNamed n => Piece (RowN n, ns) :: acc + | CModProj (m1, ms, x) => Piece (RowM (m1, ms, x), ns) :: acc + | _ => Unknown cAll :: acc + end + in + case #1 (hnormCon env c) of + CApp ( + (CApp ((CMap _, _), _), _), + r) => decomposeRow' (r, acc) + | _ => default () + end + in + decomposeRow' (c, []) + end + +and assert env denv (c1, c2) = + let + val ps1 = decomposeRow env c1 + val ps2 = decomposeRow env c2 + + val unUnknown = List.mapPartial (fn Unknown _ => NONE | Piece p => SOME p) + val ps1 = unUnknown ps1 + val ps2 = unUnknown ps2 + + (*val () = print "APieces1:\n" + val () = app pp ps1 + val () = print "APieces2:\n" + val () = app pp ps2*) + + fun assertPiece ps (p, denv) = + let + val pset = Option.getOpt (PM.find (denv, p), PS.empty) + val ps = case p of + (NameC _, _) => List.filter (fn (NameC _, _) => false | _ => true) ps + | _ => ps + val pset = PS.addList (pset, ps) + in + PM.insert (denv, p, pset) + end + + val denv = foldl (assertPiece ps2) denv ps1 + in + foldl (assertPiece ps1) denv ps2 + end + +and prove env denv (c1, c2, loc) = + let + val () = proved := !proved + 1 + val ps1 = decomposeRow env c1 + val ps2 = decomposeRow env c2 + + val hasUnknown = List.exists (fn Unknown _ => true | _ => false) + val unUnknown = List.mapPartial (fn Unknown _ => NONE | Piece p => SOME p) + in + if (hasUnknown ps1 andalso not (List.null ps2)) + orelse (hasUnknown ps2 andalso not (List.null ps1)) then + [(loc, env, denv, c1, c2)] + else + let + val ps1 = unUnknown ps1 + val ps2 = unUnknown ps2 + in + (*print "Pieces1:\n"; + app pp ps1; + print "Pieces2:\n"; + app pp ps2;*) + + foldl (fn (p1, rem) => + foldl (fn (p2, rem) => + if prove1 denv (p1, p2) then + rem + else + (loc, env, denv, pieceToRow (p1, loc), pieceToRow (p2, loc)) :: rem) rem ps2) + [] ps1 + end + end + +end diff --git a/src/effectize.sig b/src/effectize.sig new file mode 100644 index 0000000..1b638a3 --- /dev/null +++ b/src/effectize.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, 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 EFFECTIZE = sig + + val effectize : Core.file -> Core.file + +end diff --git a/src/effectize.sml b/src/effectize.sml new file mode 100644 index 0000000..2c9b237 --- /dev/null +++ b/src/effectize.sml @@ -0,0 +1,208 @@ +(* Copyright (c) 2009-2010, 2013, 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 Effective :> EFFECTIZE = struct + +open Core + +structure U = CoreUtil + +structure IM = IntBinaryMap +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x) + +fun effectize file = + let + fun expOnload evs e = + case e of + EFfi f => effectful f + | EFfiApp (m, x, _) => effectful (m, x) + | ENamed n => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) + | _ => false + + fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = expOnload evs} + + fun exp evs e = + case e of + EFfi f => effectful f + | EFfiApp (m, x, _) => effectful (m, x) + | ENamed n => IM.inDomain (evs, n) + | ERecord xets => List.exists (fn ((CName "Onload", _), e, _) => couldWriteOnload evs e + | _ => false) xets + | _ => false + + fun couldWrite evs = U.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = exp evs} + + fun exp writers readers pushers e = + case e of + ENamed n => IM.inDomain (pushers, n) + | EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) + | _ => false + + fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = exp writers readers pushers} + + fun exp evs e = + case e of + EFfi ("Basis", "getCookie") => true + | EFfiApp ("Basis", "getHeader", _) => true + | EFfiApp ("Basis", "getenv", _) => true + | ENamed n => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) + | _ => false + + fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = exp evs} + + val dejs = U.Exp.map {kind = fn x => x, + con = fn c => c, + exp = fn ERecord xets => ERecord (List.filter (fn ((CName x, _), _ , _) => x = "Onload" orelse not (String.isPrefix "On" x) + | _ => true) xets) + | e => e} + + fun doDecl (d, evs as (writers, readers, pushers)) = + case #1 d of + DVal (x, n, t, e, s) => + let + val e' = dejs e + in + (d, (if couldWrite writers e' then + IM.insert (writers, n, (#2 d, s)) + else + writers, + if couldReadCookie readers e' then + IM.insert (readers, n, (#2 d, s)) + else + readers, + if couldWriteWithRpc writers readers pushers e then + IM.insert (pushers, n, (#2 d, s)) + else + pushers)) + end + | DValRec vis => + let + fun oneRound evs = + foldl (fn ((_, n, _, e, s), (changed, (writers, readers, pushers))) => + let + val e' = dejs e + + val (changed, writers) = + if couldWrite writers e' andalso not (IM.inDomain (writers, n)) then + (true, IM.insert (writers, n, (#2 d, s))) + else + (changed, writers) + + val (changed, readers) = + if couldReadCookie readers e' andalso not (IM.inDomain (readers, n)) then + (true, IM.insert (readers, n, (#2 d, s))) + else + (changed, readers) + + val (changed, pushers) = + if couldWriteWithRpc writers readers pushers e + andalso not (IM.inDomain (pushers, n)) then + (true, IM.insert (pushers, n, (#2 d, s))) + else + (changed, pushers) + in + (changed, (writers, readers, pushers)) + end) (false, evs) vis + + fun loop evs = + let + val (b, evs) = oneRound evs + in + if b then + loop evs + else + evs + end + in + (d, loop (writers, readers, pushers)) + end + | DExport (Link _, n, t) => + (case IM.find (writers, n) of + NONE => () + | SOME (loc, s) => + if Settings.isSafeGet s then + () + else + ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s + ^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive"); + ((DExport (Link (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs)) + | DExport (Action _, n, _) => + ((DExport (Action (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), + evs) + | DExport (Rpc _, n, _) => + ((DExport (Rpc (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), + evs) + | DExport (Extern _, n, _) => + ((DExport (Extern (if IM.inDomain (writers, n) then + if IM.inDomain (readers, n) then + ReadCookieWrite + else + ReadWrite + else + ReadOnly), n, IM.inDomain (pushers, n)), #2 d), + evs) + | _ => (d, evs) + + val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty, IM.empty) file + in + file + end + +end diff --git a/src/elab.sml b/src/elab.sml new file mode 100644 index 0000000..90c14e4 --- /dev/null +++ b/src/elab.sml @@ -0,0 +1,204 @@ +(* Copyright (c) 2008-2011, 2014, 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 Elab = struct + +type 'a located = 'a ErrorMsg.located + +datatype kind' = + KType + | KArrow of kind * kind + | KName + | KRecord of kind + | KUnit + | KTuple of kind list + + | KError + | KUnif of ErrorMsg.span * string * kunif ref + | KTupleUnif of ErrorMsg.span * (int * kind) list * kunif ref + + | KRel of int + | KFun of string * kind + +and kunif = + KUnknown of kind -> bool (* Is the kind a valid unification? *) + | KKnown of kind + +withtype kind = kind' located + +datatype explicitness = + Explicit + | Implicit + +datatype con' = + TFun of con * con + | TCFun of explicitness * string * kind * con + | TRecord of con + | TDisjoint of con * con * con + + | CRel of int + | CNamed of int + | CModProj of int * string list * string + | CApp of con * con + | CAbs of string * kind * con + + | CKAbs of string * con + | CKApp of con * kind + | TKFun of string * con + + | CName of string + + | CRecord of kind * (con * con) list + | CConcat of con * con + | CMap of kind * kind + + | CUnit + + | CTuple of con list + | CProj of con * int + + | CError + | CUnif of int * ErrorMsg.span * kind * string * cunif ref + +and cunif = + Unknown of con -> bool (* Is the constructor a valid unification? *) + | Known of con + +withtype con = con' located + +datatype datatype_kind = datatype DatatypeKind.datatype_kind + +datatype patCon = + PConVar of int + | PConProj of int * string list * string + +datatype pat' = + PVar of string * con + | PPrim of Prim.t + | PCon of datatype_kind * patCon * con list * pat option + | PRecord of (string * pat * con) list + +withtype pat = pat' located + +datatype exp' = + EPrim of Prim.t + | ERel of int + | ENamed of int + | EModProj of int * string list * string + | EApp of exp * exp + | EAbs of string * con * con * exp + | ECApp of exp * con + | ECAbs of explicitness * string * kind * exp + + | EKAbs of string * exp + | EKApp of exp * kind + + | ERecord of (con * exp * con) list + | EField of exp * con * { field : con, rest : con } + | EConcat of exp * con * exp * con + | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } + + | ECase of exp * (pat * exp) list * { disc : con, result : con } + + | EError + | EUnif of exp option ref + + | ELet of edecl list * exp * con + +and edecl' = + EDVal of pat * con * exp + | EDValRec of (string * con * exp) list + +withtype exp = exp' located + and edecl = edecl' located + +(* We have to be careful about crawling automatically generated signatures recursively, + * importing all type-class instances that we find. + * The reason is that selfification will add signatures of anonymous structures, + * and it's counterintuitive for instances to escape anonymous structures! *) +datatype import_mode = Import | Skip + +datatype sgn_item' = + SgiConAbs of string * int * kind + | SgiCon of string * int * kind * con + | SgiDatatype of (string * int * string list * (string * int * con option) list) list + | SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list + | SgiVal of string * int * con + | SgiStr of import_mode * string * int * sgn + | SgiSgn of string * int * sgn + | SgiConstraint of con * con + | SgiClassAbs of string * int * kind + | SgiClass of string * int * kind * con + +and sgn' = + SgnConst of sgn_item list + | SgnVar of int + | SgnFun of string * int * sgn * sgn + | SgnWhere of sgn * string list * string * con + | SgnProj of int * string list * string + | SgnError + +withtype sgn_item = sgn_item' located +and sgn = sgn' located + +datatype decl' = + DCon of string * int * kind * con + | DDatatype of (string * int * string list * (string * int * con option) list) list + | DDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list + | DVal of string * int * con * exp + | DValRec of (string * int * con * exp) list + | DSgn of string * int * sgn + | DStr of string * int * sgn * str + | DFfiStr of string * int * sgn + | DConstraint of con * con + | DExport of int * sgn * str + | DTable of int * string * int * con * exp * con * exp * con + | DSequence of int * string * int + | DView of int * string * int * exp * con + | DDatabase of string + | DCookie of int * string * int * con + | DStyle of int * string * int + | DTask of exp * exp + | DPolicy of exp + | DOnError of int * string list * string + | DFfi of string * int * Source.ffi_mode list * con + + and str' = + StrConst of decl list + | StrVar of int + | StrProj of str * string + | StrFun of string * int * sgn * sgn * str + | StrApp of str * str + | StrError + +withtype decl = decl' located + and str = str' located + +type file = decl list + +end diff --git a/src/elab_env.sig b/src/elab_env.sig new file mode 100644 index 0000000..47b31c0 --- /dev/null +++ b/src/elab_env.sig @@ -0,0 +1,127 @@ +(* Copyright (c) 2008, 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 ELAB_ENV = sig + + val liftConInCon : int -> Elab.con -> Elab.con + val mliftConInCon : int -> Elab.con -> Elab.con + + val liftConInExp : int -> Elab.exp -> Elab.exp + val liftExpInExp : int -> Elab.exp -> Elab.exp + + val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp + + type env + + val dump : env -> unit + + val empty : env + + exception UnboundRel of int + exception UnboundNamed of int + + datatype 'a var = + NotBound + | Rel of int * 'a + | Named of int * 'a + + val pushKRel : env -> string -> env + val lookupKRel : env -> int -> string + val lookupK : env -> string -> int option + + val pushCRel : env -> string -> Elab.kind -> env + val lookupCRel : env -> int -> string * Elab.kind + + val pushCNamed : env -> string -> Elab.kind -> Elab.con option -> env * int + val pushCNamedAs : env -> string -> int -> Elab.kind -> Elab.con option -> env + val lookupCNamed : env -> int -> string * Elab.kind * Elab.con option + + val lookupC : env -> string -> Elab.kind var + + val pushDatatype : env -> int -> string list -> (string * int * Elab.con option) list -> env + type datatyp + val lookupDatatype : env -> int -> datatyp + val lookupDatatypeConstructor : datatyp -> int -> string * Elab.con option + val datatypeArgs : datatyp -> string list + val constructors : datatyp -> (string * int * Elab.con option) list + + val lookupConstructor : env -> string -> (Elab.datatype_kind * int * string list * Elab.con option * int) option + + val pushClass : env -> int -> env + val isClass : env -> Elab.con -> bool + val resolveClass : (Elab.con -> Elab.con) -> (Elab.con * Elab.con -> bool) + -> env -> Elab.con -> Elab.exp option + val resolveFailureCause : unit -> Elab.con option + val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list + + val pushERel : env -> string -> Elab.con -> env + val lookupERel : env -> int -> string * Elab.con + + val pushENamed : env -> string -> Elab.con -> env * int + val pushENamedAs : env -> string -> int -> Elab.con -> env + val lookupENamed : env -> int -> string * Elab.con + val checkENamed : env -> int -> bool + + val lookupE : env -> string -> Elab.con var + + val pushSgnNamed : env -> string -> Elab.sgn -> env * int + val pushSgnNamedAs : env -> string -> int -> Elab.sgn -> env + val lookupSgnNamed : env -> int -> string * Elab.sgn + + val lookupSgn : env -> string -> (int * Elab.sgn) option + + val pushStrNamed : env -> string -> Elab.sgn -> env * int + val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env + val pushStrNamedAs' : bool (* also enrich typeclass instances? *) -> env -> string -> int -> Elab.sgn -> env + val lookupStrNamed : env -> int -> string * Elab.sgn + + val lookupStr : env -> string -> (int * Elab.sgn) option + + val edeclBinds : env -> Elab.edecl -> env + val declBinds : env -> Elab.decl -> env + val sgiBinds : env -> Elab.sgn_item -> env + + val hnormSgn : env -> Elab.sgn -> Elab.sgn + + val projectCon : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> (Elab.kind * Elab.con option) option + val projectDatatype : env -> { sgn : Elab.sgn, str : Elab.str, field : string } + -> (string list * (string * int * Elab.con option) list) option + val projectConstructor : env -> { sgn : Elab.sgn, str : Elab.str, field : string } + -> (Elab.datatype_kind * int * string list * Elab.con option * Elab.con) option + val projectVal : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.con option + val projectSgn : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option + val projectStr : env -> { sgn : Elab.sgn, str : Elab.str, field : string } -> Elab.sgn option + val projectConstraints : env -> { sgn : Elab.sgn, str : Elab.str } -> (Elab.con * Elab.con) list option + + val newNamed : unit -> int + + val chaseMpath : env -> (int * string list) -> Elab.str * Elab.sgn + + val patBinds : env -> Elab.pat -> env + val patBindsN : Elab.pat -> int + +end diff --git a/src/elab_env.sml b/src/elab_env.sml new file mode 100644 index 0000000..8402bcb --- /dev/null +++ b/src/elab_env.sml @@ -0,0 +1,1709 @@ +(* Copyright (c) 2008-2009, 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 ElabEnv :> ELAB_ENV = struct + +open Elab + +structure U = ElabUtil + +structure IM = IntBinaryMap +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +exception UnboundRel of int +exception UnboundNamed of int + + +(* AST utility functions *) + +val liftKindInKind = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + bind = fn (bound, _) => bound + 1} + +val liftKindInCon = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + +val liftConInCon = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} + +val lift = liftConInCon 0 + +fun mliftConInCon by c = + if by = 0 then + c + else + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + by) + | CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} 0 c + +val () = U.mliftConInCon := mliftConInCon + +val liftKindInExp = + U.Exp.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelK _) => bound + 1 + | (bound, _) => bound} + +val liftConInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | CUnif (nl, loc, k, s, r) => CUnif (nl+1, loc, k, s, r) + | _ => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelC _) => bound + 1 + | (bound, _) => bound} + +val liftExpInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + + +val liftExp = liftExpInExp 0 + +val subExpInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + +(* Back to environments *) + +datatype 'a var' = + Rel' of int * 'a + | Named' of int * 'a + +datatype 'a var = + NotBound + | Rel of int * 'a + | Named of int * 'a + +type datatyp = string list * (string * con option) IM.map + +datatype class_name = + ClNamed of int + | ClProj of int * string list * string + +fun class_name_out cn = + case cn of + ClNamed n => (CNamed n, ErrorMsg.dummySpan) + | ClProj x => (CModProj x, ErrorMsg.dummySpan) + +fun cn2s cn = + case cn of + ClNamed n => "Named(" ^ Int.toString n ^ ")" + | ClProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" + +structure CK = struct +type ord_key = class_name +open Order +fun compare x = + case x of + (ClNamed n1, ClNamed n2) => Int.compare (n1, n2) + | (ClNamed _, _) => LESS + | (_, ClNamed _) => GREATER + + | (ClProj (m1, ms1, x1), ClProj (m2, ms2, x2)) => + join (Int.compare (m1, m2), + fn () => join (joinL String.compare (ms1, ms2), + fn () => String.compare (x1, x2))) +end + +structure CS = BinarySetFn(CK) +structure CM = BinaryMapFn(CK) + +type rules = (int * con list * con * exp) list + +type class = {closedRules : rules, + openRules : rules} +val empty_class = {closedRules = [], + openRules = []} + +type env = { + renameK : int SM.map, + relK : string list, + + renameC : kind var' SM.map, + relC : (string * kind) list, + namedC : (string * kind * con option) IM.map, + + datatypes : datatyp IM.map, + constructors : (datatype_kind * int * string list * con option * int) SM.map, + + classes : class CM.map, + + renameE : con var' SM.map, + relE : (string * con) list, + namedE : (string * con) IM.map, + + renameSgn : (int * sgn) SM.map, + sgn : (string * sgn) IM.map, + + renameStr : (int * sgn) SM.map, + str : (string * sgn) IM.map +} + +fun dump (env : env) = + (print "NamedC:\n"; + IM.appi (fn (n, (x, k, co)) => print (x ^ " [" ^ Int.toString n ^ "]\n")) (#namedC env)) + +val namedCounter = ref 0 + +fun newNamed () = + let + val r = !namedCounter + in + namedCounter := r + 1; + r + end + +val empty = { + renameK = SM.empty, + relK = [], + + renameC = SM.empty, + relC = [], + namedC = IM.empty, + + datatypes = IM.empty, + constructors = SM.empty, + + classes = CM.empty, + + renameE = SM.empty, + relE = [], + namedE = IM.empty, + + renameSgn = SM.empty, + sgn = IM.empty, + + renameStr = SM.empty, + str = IM.empty +} + +fun pushKRel (env : env) x = + let + val renameK = SM.map (fn n => n+1) (#renameK env) + in + {renameK = SM.insert (renameK, x, 0), + relK = x :: #relK env, + + renameC = SM.map (fn Rel' (n, k) => Rel' (n, liftKindInKind 0 k) + | x => x) (#renameC env), + relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env), + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = CM.map (fn cl => {closedRules = #closedRules cl, + openRules = map (fn (nvs, cs, c, e) => + (nvs, + map (liftKindInCon 0) cs, + liftKindInCon 0 c, + liftKindInExp 0 e)) + (#openRules cl)}) + (#classes env), + + renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c) + | Named' (n, c) => Named' (n, c)) (#renameE env), + relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env), + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env + } + end + +fun lookupKRel (env : env) n = + (List.nth (#relK env, n)) + handle Subscript => raise UnboundRel n + +fun lookupK (env : env) x = SM.find (#renameK env, x) + +fun pushCRel (env : env) x k = + let + val renameC = SM.map (fn Rel' (n, k) => Rel' (n+1, k) + | x => x) (#renameC env) + in + {renameK = #renameK env, + relK = #relK env, + + renameC = SM.insert (renameC, x, Rel' (0, k)), + relC = (x, k) :: #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = CM.map (fn class => + {closedRules = #closedRules class, + openRules = map (fn (nvs, cs, c, e) => + (nvs, + map (liftConInCon 0) cs, + liftConInCon 0 c, + liftConInExp 0 e)) + (#openRules class)}) + (#classes env), + + renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) + | Named' (n, c) => Named' (n, c)) (#renameE env), + relE = map (fn (x, c) => (x, lift c)) (#relE env), + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env + } + end + +fun lookupCRel (env : env) n = + (List.nth (#relC env, n)) + handle Subscript => raise UnboundRel n + +fun pushCNamedAs (env : env) x n k co = + {renameK = #renameK env, + relK = #relK env, + + renameC = SM.insert (#renameC env, x, Named' (n, k)), + relC = #relC env, + namedC = IM.insert (#namedC env, n, (x, k, co)), + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = #classes env, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} + +fun pushCNamed env x k co = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushCNamedAs env x n k co, n) + end + +fun lookupCNamed (env : env) n = + case IM.find (#namedC env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupC (env : env) x = + case SM.find (#renameC env, x) of + NONE => NotBound + | SOME (Rel' x) => Rel x + | SOME (Named' x) => Named x + +fun pushDatatype (env : env) n xs xncs = + let + val dk = U.classifyDatatype xncs + in + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = IM.insert (#datatypes env, n, + (xs, foldl (fn ((x, n, to), cons) => + IM.insert (cons, n, (x, to))) IM.empty xncs)), + constructors = foldl (fn ((x, n', to), cmap) => + SM.insert (cmap, x, (dk, n', xs, to, n))) + (#constructors env) xncs, + + classes = #classes env, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} + end + +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupDatatypeConstructor (_, dt) n = + case IM.find (dt, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupConstructor (env : env) s = SM.find (#constructors env, s) + +fun datatypeArgs (xs, _) = xs +fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt + +fun listClasses (env : env) = + map (fn (cn, {closedRules, openRules}) => + (class_name_out cn, + map (fn (nvs, cs, c, e) => + let + val loc = #2 c + val c = foldr (fn (c', c) => (TFun (c', c), loc)) c cs + val c = ListUtil.foldli (fn (n, (), c) => (TCFun (Explicit, + "x" ^ Int.toString n, + (KError, loc), + c), loc)) + c (List.tabulate (nvs, fn _ => ())) + in + (c, e) + end) (closedRules @ openRules))) (CM.listItemsi (#classes env)) + +fun pushClass (env : env) n = + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = CM.insert (#classes env, ClNamed n, empty_class), + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} + +fun class_name_in (c, _) = + case c of + CNamed n => SOME (ClNamed n) + | CModProj x => SOME (ClProj x) + | CUnif (_, _, _, _, ref (Known c)) => class_name_in c + | _ => NONE + +fun isClass (env : env) c = + let + fun find NONE = false + | find (SOME c) = Option.isSome (CM.find (#classes env, c)) + in + find (class_name_in c) + end + +fun class_head_in c = + case #1 c of + CApp (f, _) => class_head_in f + | CUnif (_, _, _, _, ref (Known c)) => class_head_in c + | _ => class_name_in c + +exception Unify + +fun unifyKinds (k1, k2) = + case (#1 k1, #1 k2) of + (KType, KType) => () + | (KArrow (d1, r1), KArrow (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + | (KName, KName) => () + | (KRecord k1, KRecord k2) => unifyKinds (k1, k2) + | (KUnit, KUnit) => () + | (KTuple ks1, KTuple ks2) => (ListPair.appEq unifyKinds (ks1, ks2) + handle ListPair.UnequalLengths => raise Unify) + | (KUnif (_, _, ref (KKnown k1)), _) => unifyKinds (k1, k2) + | (_, KUnif (_, _, ref (KKnown k2))) => unifyKinds (k1, k2) + | (KRel n1, KRel n2) => if n1 = n2 then () else raise Unify + | (KFun (_, k1), KFun (_, k2)) => unifyKinds (k1, k2) + | _ => raise Unify + +fun eqCons (c1, c2) = + case (#1 c1, #1 c2) of + (CUnif (nl, _, _, _, ref (Known c1)), _) => eqCons (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (Known c2))) => eqCons (c1, mliftConInCon nl c2) + + | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify + + | (TFun (d1, r1), TFun (d2, r2)) => (eqCons (d1, d2); eqCons (r1, r2)) + | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); eqCons (r1, r2)) + | (TRecord c1, TRecord c2) => eqCons (c1, c2) + | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => + (eqCons (a1, a2); eqCons (b1, b2); eqCons (c1, c2)) + + | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify + | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify + | (CApp (f1, x1), CApp (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) + | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); eqCons (b1, b2)) + + | (CKAbs (_, b1), CKAbs (_, b2)) => eqCons (b1, b2) + | (CKApp (c1, k1), CKApp (c2, k2)) => (eqCons (c1, c2); unifyKinds (k1, k2)) + | (TKFun (_, c1), TKFun (_, c2)) => eqCons (c1, c2) + + | (CName s1, CName s2) => if s1 = s2 then () else raise Unify + + | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => + (unifyKinds (k1, k2); + if length xcs1 <> length xcs2 then + raise Unify + else + List.app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (eqCons (x1, x2); eqCons (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) + | (CConcat (f1, x1), CConcat (f2, x2)) => (eqCons (f1, f2); eqCons (x1, x2)) + | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + + | (CUnit, CUnit) => () + + | (CTuple cs1, CTuple cs2) => (ListPair.appEq (eqCons) (cs1, cs2) + handle ListPair.UnequalLengths => raise Unify) + | (CProj (c1, n1), CProj (c2, n2)) => (eqCons (c1, c2); + if n1 = n2 then () else raise Unify) + + | _ => raise Unify + +fun unifyCons (hnorm : con -> con) rs = + let + fun unify d (c1, c2) = + case (#1 (hnorm c1), #1 (hnorm c2)) of + (CUnif (nl, _, _, _, ref (Known c1)), _) => unify d (mliftConInCon nl c1, c2) + | (_, CUnif (nl, _, _, _, ref (Known c2))) => unify d (c1, mliftConInCon nl c2) + + | (CUnif _, _) => () + + | (c1', CRel n2) => + if n2 < d then + case c1' of + CRel n1 => if n1 = n2 then () else raise Unify + | _ => raise Unify + else if n2 - d >= length rs then + case c1' of + CRel n1 => if n1 = n2 - length rs then () else raise Unify + | _ => raise Unify + else + let + val r = List.nth (rs, n2 - d) + in + case !r of + NONE => r := SOME c1 + | SOME c2 => eqCons (c1, c2) + end + + | (TFun (d1, r1), TFun (d2, r2)) => (unify d (d1, d2); unify d (r1, r2)) + | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (d + 1) (r1, r2)) + | (TRecord c1, TRecord c2) => unify d (c1, c2) + | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) => + (unify d (a1, a2); unify d (b1, b2); unify d (c1, c2)) + + | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify + | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify + | (CApp (f1, x1), CApp (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) + | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (d + 1) (b1, b2)) + + | (CKAbs (_, b1), CKAbs (_, b2)) => unify d (b1, b2) + | (CKApp (c1, k1), CKApp (c2, k2)) => (unify d (c1, c2); unifyKinds (k1, k2)) + | (TKFun (_, c1), TKFun (_, c2)) => unify d (c1, c2) + + | (CName s1, CName s2) => if s1 = s2 then () else raise Unify + + | (CRecord (k1, xcs1), CRecord (k2, xcs2)) => + (unifyKinds (k1, k2); + if length xcs1 <> length xcs2 then + raise Unify + else + app (fn (x1, c1) => + if List.exists (fn (x2, c2) => (unify d (x1, x2); unify d (c1, c2); true) handle Unify => false) xcs2 then + () + else + raise Unify) xcs1) + | (CConcat (f1, x1), CConcat (f2, x2)) => (unify d (f1, f2); unify d (x1, x2)) + | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2)) + + | (CUnit, CUnit) => () + + | (CTuple cs1, CTuple cs2) => (ListPair.appEq (unify d) (cs1, cs2) + handle ListPair.UnequalLengths => raise Unify) + | (CProj (c1, n1), CProj (c2, n2)) => (unify d (c1, c2); + if n1 = n2 then () else raise Unify) + + | _ => raise Unify + in + unify + end + +fun tryUnify hnorm nRs (c1, c2) = + let + val rs = List.tabulate (nRs, fn _ => ref NONE) + in + (unifyCons hnorm rs 0 (c1, c2); + SOME (map (fn r => case !r of + NONE => raise Unify + | SOME c => c) rs)) + handle Unify => NONE + end + +fun unifySubst (rs : con list) = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn d => fn c => + case c of + CRel n => + if n < d then + c + else if n - d >= length rs then + CRel (n - d) + else + #1 (List.nth (rs, n - d)) + | _ => c, + bind = fn (d, U.Con.RelC _) => d + 1 + | (d, _) => d} + 0 + +exception Bad of con * con + +val hasUnif = U.Con.exists {kind = fn _ => false, + con = fn CUnif (_, _, _, _, ref (Unknown _)) => true + | _ => false} + +fun startsWithUnif c = + let + fun firstArg (c, acc) = + case #1 c of + CApp (f, x) => firstArg (f, SOME x) + | _ => acc + in + case firstArg (c, NONE) of + NONE => false + | SOME x => hasUnif x + end + +val cause = ref (NONE : con option) +fun resolveFailureCause () = !cause + +fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = + let + fun resolve firstLevel c = + let + fun notFound () = (if firstLevel then () else cause := SOME c; NONE) + + fun doHead f = + case CM.find (#classes env, f) of + NONE => notFound () + | SOME class => + let + val loc = #2 c + + fun generalize (c as (_, loc)) = + case #1 c of + CApp (f, x) => + let + val (f, equate) = generalize f + + fun isRecord () = + let + val rk = ref (KUnknown (fn _ => true)) + val k = (KUnif (loc, "k", rk), loc) + val r = ref (Unknown (fn _ => true)) + val rc = (CUnif (0, loc, k, "x", r), loc) + in + ((CApp (f, rc), loc), + fn () => (if consEq (rc, x) then + true + else + (raise Bad (rc, x); + false)) + andalso equate ()) + end + in + case #1 x of + CConcat _ => isRecord () + | CRecord _ => isRecord () + | _ => ((CApp (f, x), loc), equate) + end + | _ => (c, fn () => true) + + val (c, equate) = generalize c + + fun tryRules rules = + case rules of + [] => notFound () + | (nRs, cs, c', e) :: rules' => + case tryUnify hnorm nRs (c, c') of + NONE => tryRules rules' + | SOME rs => + let + val eos = map (resolve false o unifySubst rs) cs + in + if List.exists (not o Option.isSome) eos + orelse not (equate ()) + orelse not (consEq (c, unifySubst rs c')) then + tryRules rules' + else + let + val es = List.mapPartial (fn x => x) eos + + val e = foldr (fn (c, e) => (ECApp (e, c), loc)) e rs + val e = foldl (fn (e', e) => (EApp (e, e'), loc)) e es + in + SOME e + end + end + in + tryRules (#openRules class @ #closedRules class) + end + in + if startsWithUnif c then + notFound () + else + case #1 c of + TRecord c => + (case #1 (hnorm c) of + CRecord (_, xts) => + let + fun resolver (xts, acc) = + case xts of + [] => SOME (ERecord acc, #2 c) + | (x, t) :: xts => + let + val t = hnorm t + + val t = case t of + (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) + | _ => t + in + case resolve false t of + NONE => notFound () + | SOME e => resolver (xts, (x, e, t) :: acc) + end + in + resolver (xts, []) + end + | _ => notFound ()) + | _ => + case class_head_in c of + SOME f => doHead f + | _ => notFound () + end + in + cause := NONE; + resolve true + end + +fun rule_in c = + let + fun quantifiers (c, nvars) = + case #1 c of + CUnif (_, _, _, _, ref (Known c)) => quantifiers (c, nvars) + | TCFun (_, _, _, c) => quantifiers (c, nvars + 1) + | _ => + let + fun clauses (c, hyps) = + case #1 c of + TFun (hyp, c) => + (case class_head_in hyp of + SOME _ => clauses (c, hyp :: hyps) + | NONE => NONE) + | _ => + case class_head_in c of + NONE => NONE + | SOME f => SOME (f, nvars, rev hyps, c) + in + clauses (c, []) + end + in + quantifiers (c, 0) + end + +fun pushERel (env : env) x t = + let + val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t) + | x => x) (#renameE env) + + val classes = CM.map (fn class => + {openRules = map (fn (nvs, cs, c, e) => (nvs, cs, c, liftExp e)) (#openRules class), + closedRules = #closedRules class}) (#classes env) + val classes = case rule_in t of + NONE => classes + | SOME (f, nvs, cs, c) => + case CM.find (classes, f) of + NONE => classes + | SOME class => + let + val rule = (nvs, cs, c, (ERel 0, #2 t)) + + val class = {openRules = rule :: #openRules class, + closedRules = #closedRules class} + in + CM.insert (classes, f, class) + end + in + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = classes, + + renameE = SM.insert (renameE, x, Rel' (0, t)), + relE = (x, t) :: #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} + end + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun pushENamedAs (env : env) x n t = + let + val classes = #classes env + val classes = case rule_in t of + NONE => classes + | SOME (f, nvs, cs, c) => + case CM.find (classes, f) of + NONE => classes + | SOME class => + let + val e = (ENamed n, #2 t) + + val class = + {openRules = #openRules class, + closedRules = (nvs, cs, c, e) :: #closedRules class} + in + CM.insert (classes, f, class) + end + in + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = classes, + + renameE = SM.insert (#renameE env, x, Named' (n, t)), + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t)), + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = #renameStr env, + str = #str env} + end + +fun pushENamed env x t = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushENamedAs env x n t, n) + end + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun checkENamed (env : env) n = + Option.isSome (IM.find (#namedE env, n)) + +fun lookupE (env : env) x = + case SM.find (#renameE env, x) of + NONE => NotBound + | SOME (Rel' x) => Rel x + | SOME (Named' x) => Named x + +fun pushSgnNamedAs (env : env) x n sgis = + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = #classes env, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = SM.insert (#renameSgn env, x, (n, sgis)), + sgn = IM.insert (#sgn env, n, (x, sgis)), + + renameStr = #renameStr env, + str = #str env} + +fun pushSgnNamed env x sgis = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushSgnNamedAs env x n sgis, n) + end + +fun lookupSgnNamed (env : env) n = + case IM.find (#sgn env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupSgn (env : env) x = SM.find (#renameSgn env, x) + +fun lookupStrNamed (env : env) n = + case IM.find (#str env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupStr (env : env) x = SM.find (#renameStr env, x) + + +fun sgiSeek (sgi, (sgns, strs, cons)) = + case sgi of + SgiConAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiCon (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiDatatype dts => (sgns, strs, foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts) + | SgiDatatypeImp (x, n, _, _, _, _, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiVal _ => (sgns, strs, cons) + | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) + | SgiStr (_, x, n, _) => (sgns, IM.insert (strs, n, x), cons) + | SgiConstraint _ => (sgns, strs, cons) + | SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) + +fun sgnSeek f sgis = + let + fun seek (sgis, sgns, strs, cons) = + case sgis of + [] => NONE + | (sgi, _) :: sgis => + case f sgi of + SOME v => + let + val cons = + case sgi of + SgiDatatype dts => foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts + | SgiDatatypeImp (x, n, _, _, _, _, _) => IM.insert (cons, n, x) + | _ => cons + in + SOME (v, (sgns, strs, cons)) + end + | NONE => + let + val (sgns, strs, cons) = sgiSeek (sgi, (sgns, strs, cons)) + in + seek (sgis, sgns, strs, cons) + end + in + seek (sgis, IM.empty, IM.empty, IM.empty) + end + +fun id x = x + +fun unravelStr (str, _) = + case str of + StrVar x => (x, []) + | StrProj (str, m) => + let + val (x, ms) = unravelStr str + in + (x, ms @ [m]) + end + | _ => raise Fail "unravelStr" + +fun sgnS_con (str, (sgns, strs, cons)) c = + case c of + CModProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => c + | SOME m1x => + let + val (m1, ms') = unravelStr str + in + CModProj (m1, ms' @ m1x :: ms, x) + end) + | CNamed n => + (case IM.find (cons, n) of + NONE => c + | SOME nx => + let + val (m1, ms) = unravelStr str + in + CModProj (m1, ms, nx) + end) + | _ => c + +fun sgnS_con' (m1, ms', (sgns, strs, cons)) = + U.Con.map {kind = fn x => x, + con = fn c => + case c of + CModProj (m1', ms, x) => + (case IM.find (strs, m1') of + NONE => c + | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) + | CNamed n => + (case IM.find (cons, n) of + NONE => c + | SOME nx => CModProj (m1, ms', nx)) + | _ => c} + +fun sgnS_sgn (str, (sgns, strs, cons)) sgn = + case sgn of + SgnProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => sgn + | SOME m1x => + let + val (m1, ms') = unravelStr str + in + SgnProj (m1, ms' @ m1x :: ms, x) + end) + | SgnVar n => + (case IM.find (sgns, n) of + NONE => sgn + | SOME nx => + let + val (m1, ms) = unravelStr str + in + SgnProj (m1, ms, nx) + end) + | _ => sgn + +fun projectStr env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of + NONE => NONE + | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) + | SgnError => SOME (SgnError, ErrorMsg.dummySpan) + | _ => NONE + +and sgnSubSgn x = + ElabUtil.Sgn.map {kind = id, + con = sgnS_con x, + sgn_item = id, + sgn = sgnS_sgn x} + +and projectSgn env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + (case sgnSeek (fn SgiSgn (x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of + NONE => NONE + | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn)) + | SgnError => SOME (SgnError, ErrorMsg.dummySpan) + | _ => NONE + +and hnormSgn env (all as (sgn, loc)) = + case sgn of + SgnError => all + | SgnVar n => hnormSgn env (#2 (lookupSgnNamed env n)) + | SgnConst _ => all + | SgnFun _ => all + | SgnProj (m, ms, x) => + let + val (_, sgn) = lookupStrNamed env m + + fun doProjection (m1, NONE) = NONE + | doProjection (m1, SOME (str, sgn)) = + case projectStr env {str = str, + sgn = sgn, + field = m1} of + NONE => NONE + | SOME sgn' => SOME ((StrProj (str, m1), loc), sgn') + in + case foldl doProjection (SOME ((StrVar m, loc), sgn)) ms of + NONE => raise Fail "ElabEnv.hnormSgn: pre-projectSgn failed" + | SOME (str, sgn) => + case projectSgn env {str = str, + sgn = sgn, + field = x} of + NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed" + | SOME sgn => hnormSgn env sgn + end + | SgnWhere (sgn, ms, x, c) => + let + fun rewrite (sgn, ms) = + case #1 (hnormSgn env sgn) of + SgnError => (SgnError, loc) + | SgnConst sgis => + let + fun traverse (ms, pre, post) = + case post of + [] => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [1]" + + | (sgi as (SgiConAbs (x', n, k), loc)) :: rest => + if List.null ms andalso x = x' then + List.revAppend (pre, (SgiCon (x', n, k, c), loc) :: rest) + else + traverse (ms, sgi :: pre, rest) + + | (sgi as (SgiStr (im, x', n, sgn'), loc)) :: rest => + (case ms of + [] => traverse (ms, sgi :: pre, rest) + | x :: ms' => + if x = x' then + List.revAppend (pre, + (SgiStr (im, x', n, + rewrite (sgn', ms')), loc) :: rest) + else + traverse (ms, sgi :: pre, rest)) + + | sgi :: rest => traverse (ms, sgi :: pre, rest) + + val sgis = traverse (ms, [], sgis) + in + (SgnConst sgis, loc) + end + | _ => raise Fail "ElabEnv.hnormSgn: Can't reduce 'where' [2]" + in + rewrite (sgn, ms) + end + +fun manifest (m, ms, loc) = + foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms + +fun enrichClasses env classes (m1, ms) sgn = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + let + val (classes, _, _, _) = + foldl (fn (sgi, (classes, newClasses, fmap, env)) => + let + fun found (x, n) = + (CM.insert (classes, + ClProj (m1, ms, x), + empty_class), + IM.insert (newClasses, n, x), + sgiSeek (#1 sgi, fmap), + env) + + fun default () = (classes, newClasses, sgiSeek (#1 sgi, fmap), env) + in + case #1 sgi of + SgiStr (Import, x, _, sgn) => + let + val str = manifest (m1, ms, #2 sgi) + val sgn' = sgnSubSgn (str, fmap) sgn + in + (enrichClasses env classes (m1, ms @ [x]) sgn', + newClasses, + sgiSeek (#1 sgi, fmap), + env) + end + | SgiSgn (x, n, sgn) => + (classes, + newClasses, + fmap, + pushSgnNamedAs env x n sgn) + + | SgiClassAbs (x, n, _) => found (x, n) + | SgiClass (x, n, _, _) => found (x, n) + | SgiVal (x, n, c) => + (case rule_in c of + NONE => default () + | SOME (cn, nvs, cs, c) => + let + val loc = #2 c + val globalize = sgnS_con' (m1, ms, fmap) + + val nc = + case cn of + ClNamed f => IM.find (newClasses, f) + | _ => NONE + in + case nc of + NONE => + let + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val e = (EModProj (m1, ms, x), #2 sgn) + + val class = + {openRules = #openRules class, + closedRules = (nvs, + map globalize cs, + globalize c, + e) :: #closedRules class} + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + | SOME fx => + let + val cn = ClProj (m1, ms, fx) + + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val e = (EModProj (m1, ms, x), #2 sgn) + + val class = + {openRules = #openRules class, + closedRules = (nvs, + map globalize cs, + globalize c, + e) :: #closedRules class} + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + end) + | _ => default () + end) + (classes, IM.empty, (IM.empty, IM.empty, IM.empty), env) sgis + in + classes + end + | _ => classes + +and pushStrNamedAs' enrich (env : env) x n sgn = + let + val renameStr = SM.insert (#renameStr env, x, (n, sgn)) + val str = IM.insert (#str env, n, (x, sgn)) + fun newEnv classes = + {renameK = #renameK env, + relK = #relK env, + + renameC = #renameC env, + relC = #relC env, + namedC = #namedC env, + + datatypes = #datatypes env, + constructors = #constructors env, + + classes = classes, + + renameE = #renameE env, + relE = #relE env, + namedE = #namedE env, + + renameSgn = #renameSgn env, + sgn = #sgn env, + + renameStr = renameStr, + str = str} + in + if enrich then + newEnv (enrichClasses (newEnv (#classes env)) (#classes env) (n, []) sgn) + else + newEnv (#classes env) + end + +and pushStrNamedAs env = pushStrNamedAs' true env + +fun pushStrNamed env x sgn = + let + val n = !namedCounter + in + namedCounter := n + 1; + (pushStrNamedAs env x n sgn, n) + end + +fun sgiBinds env (sgi, loc) = + case sgi of + SgiConAbs (x, n, k) => pushCNamedAs env x n k NONE + | SgiCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) + | SgiDatatype dts => + let + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs + + val env = pushCNamedAs env x n k' NONE + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) + + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end + in + foldl doOne env dts + end + | SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => + let + val k = (KType, loc) + val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs + + val env = pushCNamedAs env x n k' (SOME (CModProj (m1, ms, x'), loc)) + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) + + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (Explicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end + | SgiVal (x, n, t) => pushENamedAs env x n t + | SgiStr (_, x, n, sgn) => pushStrNamedAs' false env x n sgn + | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn + | SgiConstraint _ => env + + | SgiClassAbs (x, n, k) => pushCNamedAs env x n k NONE + | SgiClass (x, n, k, c) => pushCNamedAs env x n k (SOME c) + +fun sgnSubCon x = + ElabUtil.Con.map {kind = id, + con = sgnS_con x} + +fun chaseMpath env (n, ms) = + let + val (_, sgn) = lookupStrNamed env n + in + foldl (fn (m, (str, sgn)) => + case projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "kindof: Unknown substructure" + | SOME sgn => ((StrProj (str, m), #2 sgn), sgn)) + ((StrVar n, #2 sgn), sgn) ms + end + +fun projectCon env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + (case sgnSeek (fn SgiConAbs (x, _, k) => if x = field then SOME (k, NONE) else NONE + | SgiCon (x, _, k, c) => if x = field then SOME (k, SOME c) else NONE + | SgiDatatype dts => + (case List.find (fn (x, _, xs, _) => x = field) dts of + SOME (_, _, xs, _) => + let + val k = (KType, #2 sgn) + val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs + in + SOME (k', NONE) + end + | NONE => NONE) + | SgiDatatypeImp (x, _, m1, ms, x', xs, _) => + if x = field then + let + val k = (KType, #2 sgn) + val k' = foldl (fn (_, k') => (KArrow (k, k'), #2 sgn)) k xs + in + SOME (k', SOME (CModProj (m1, ms, x'), #2 sgn)) + end + else + NONE + | SgiClassAbs (x, _, k) => if x = field then + SOME (k, NONE) + else + NONE + | SgiClass (x, _, k, c) => if x = field then + SOME (k, SOME c) + else + NONE + | _ => NONE) sgis of + NONE => NONE + | SOME ((k, co), subs) => SOME (k, Option.map (sgnSubCon (str, subs)) co)) + | SgnError => SOME ((KError, ErrorMsg.dummySpan), SOME (CError, ErrorMsg.dummySpan)) + | _ => NONE + +fun projectDatatype env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + (case sgnSeek (fn SgiDatatype dts => + (case List.find (fn (x, _, _, _) => x = field) dts of + SOME (_, _, xs, xncs) => SOME (xs, xncs) + | NONE => NONE) + | SgiDatatypeImp (x, _, _, _, _, xs, xncs) => if x = field then SOME (xs, xncs) else NONE + | _ => NONE) sgis of + NONE => NONE + | SOME ((xs, xncs), subs) => SOME (xs, + map (fn (x, n, to) => (x, n, Option.map (sgnSubCon (str, subs)) to)) xncs)) + | _ => NONE + +fun projectConstructor env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + let + fun consider (n, xs, xncs) = + ListUtil.search (fn (x, n', to) => + if x <> field then + NONE + else + SOME (U.classifyDatatype xncs, n', xs, to, (CNamed n, #2 str))) xncs + in + case sgnSeek (fn SgiDatatype dts => + let + fun search dts = + case dts of + [] => NONE + | (_, n, xs, xncs) :: dts => + case consider (n, xs, xncs) of + NONE => search dts + | v => v + in + search dts + end + | SgiDatatypeImp (_, n, _, _, _, xs, xncs) => consider (n, xs, xncs) + | _ => NONE) sgis of + NONE => NONE + | SOME ((dk, n, xs, to, t), subs) => SOME (dk, n, xs, Option.map (sgnSubCon (str, subs)) to, + sgnSubCon (str, subs) t) + end + | _ => NONE + +fun projectVal env {sgn, str, field} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => + let + fun seek (n, xs, xncs) = + ListUtil.search (fn (x, _, to) => + if x = field then + SOME (let + val base = (CNamed n, #2 sgn) + val nxs = length xs + val base = ListUtil.foldli (fn (i, _, base) => + (CApp (base, + (CRel (nxs - i - 1), #2 sgn)), + #2 sgn)) + base xs + + val t = + case to of + NONE => base + | SOME t => (TFun (t, base), #2 sgn) + val k = (KType, #2 sgn) + in + foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn)) + t xs + end) + else + NONE) xncs + in + case sgnSeek (fn SgiVal (x, _, c) => if x = field then SOME c else NONE + | SgiDatatype dts => + let + fun search dts = + case dts of + [] => NONE + | (_, n, xs, xncs) :: dts => + case seek (n, xs, xncs) of + NONE => search dts + | v => v + in + search dts + end + | SgiDatatypeImp (_, n, _, _, _, xs, xncs) => seek (n, xs, xncs) + | _ => NONE) sgis of + NONE => NONE + | SOME (c, subs) => SOME (sgnSubCon (str, subs) c) + end + | SgnError => SOME (CError, ErrorMsg.dummySpan) + | _ => NONE + +fun sgnSeekConstraints (str, sgis) = + let + fun seek (sgis, sgns, strs, cons, acc) = + case sgis of + [] => acc + | (sgi, _) :: sgis => + case sgi of + SgiConstraint (c1, c2) => + let + val sub = sgnSubCon (str, (sgns, strs, cons)) + in + seek (sgis, sgns, strs, cons, (sub c1, sub c2) :: acc) + end + | SgiConAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiCon (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiDatatype dts => seek (sgis, sgns, strs, + foldl (fn ((x, n, _, _), cons) => IM.insert (cons, n, x)) cons dts, acc) + | SgiDatatypeImp (x, n, _, _, _, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiVal _ => seek (sgis, sgns, strs, cons, acc) + | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) + | SgiStr (_, x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) + | SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + in + seek (sgis, IM.empty, IM.empty, IM.empty, []) + end + +fun projectConstraints env {sgn, str} = + case #1 (hnormSgn env sgn) of + SgnConst sgis => SOME (sgnSeekConstraints (str, sgis)) + | SgnError => SOME [] + | _ => NONE + +fun patBinds env (p, loc) = + case p of + PVar (x, t) => pushERel env x t + | PPrim _ => env + | PCon (_, _, _, NONE) => env + | PCon (_, _, _, SOME p) => patBinds env p + | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps + +fun patBindsN (p, _) = + case p of + PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), n) => patBindsN p + n) 0 xps + +fun edeclBinds env (d, loc) = + case d of + EDVal (p, _, _) => patBinds env p + | EDValRec vis => foldl (fn ((x, t, _), env) => pushERel env x t) env vis + +fun declBinds env (d, loc) = + case d of + DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val env = pushCNamedAs env x n kb NONE + val env = pushDatatype env n xs xncs + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end + in + foldl doOne env dts + end + | DDatatypeImp (x, n, m, ms, x', xs, xncs) => + let + val t = (CModProj (m, ms, x'), loc) + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val env = pushCNamedAs env x n kb (SOME t) + val env = pushDatatype env n xs xncs + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (Implicit, x, k, t), loc)) t xs + in + pushENamedAs env x' n' t + end) + env xncs + end + | DVal (x, n, t, _) => pushENamedAs env x n t + | DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis + | DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn + | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn + | DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn + | DConstraint _ => env + | DExport _ => env + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (tn, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + pushENamedAs env x n ct + end + | DSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) + in + pushENamedAs env x n t + end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamedAs env x n ct + end + | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "cookie"), loc), c), loc) + in + pushENamedAs env x n t + end + | DStyle (tn, x, n) => + let + val t = (CModProj (tn, [], "css_class"), loc) + in + pushENamedAs env x n t + end + | DTask _ => env + | DPolicy _ => env + | DOnError _ => env + | DFfi (x, n, _, t) => pushENamedAs env x n t + +end diff --git a/src/elab_err.sig b/src/elab_err.sig new file mode 100644 index 0000000..acf137d --- /dev/null +++ b/src/elab_err.sig @@ -0,0 +1,125 @@ +(* 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. + *) + +signature ELAB_ERR = sig + + datatype kind_error = + UnboundKind of ErrorMsg.span * string + + val kindError : ElabEnv.env -> kind_error -> unit + + datatype kunify_error = + KOccursCheckFailed of Elab.kind * Elab.kind + | KIncompatible of Elab.kind * Elab.kind + | KScope of Elab.kind * Elab.kind + + val kunifyError : ElabEnv.env -> kunify_error -> unit + + datatype con_error = + UnboundCon of ErrorMsg.span * string + | UnboundDatatype of ErrorMsg.span * string + | UnboundStrInCon of ErrorMsg.span * string + | WrongKind of Elab.con * Elab.kind * Elab.kind * ElabEnv.env * kunify_error + | DuplicateField of ErrorMsg.span * string + | ProjBounds of Elab.con * int + | ProjMismatch of Elab.con * Elab.kind + + val conError : ElabEnv.env -> con_error -> unit + + datatype cunify_error = + CKind of Elab.kind * Elab.kind * ElabEnv.env * kunify_error + | COccursCheckFailed of Elab.con * Elab.con + | CIncompatible of Elab.con * Elab.con + | CExplicitness of Elab.con * Elab.con + | CKindof of Elab.kind * Elab.con * string + | CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con * (ElabEnv.env * cunify_error) option) option + | TooLifty of ErrorMsg.span * ErrorMsg.span + | TooUnify of Elab.con * Elab.con + | TooDeep + | CScope of Elab.con * Elab.con + + val cunifyError : ElabEnv.env -> cunify_error -> unit + + datatype exp_error = + UnboundExp of ErrorMsg.span * string + | UnboundStrInExp of ErrorMsg.span * string + | Unify of Elab.exp * Elab.con * Elab.con * ElabEnv.env * cunify_error + | Unif of string * ErrorMsg.span * Elab.con + | WrongForm of string * Elab.exp * Elab.con + | IncompatibleCons of Elab.con * Elab.con + | DuplicatePatternVariable of ErrorMsg.span * string + | PatUnify of Elab.pat * Elab.con * Elab.con * ElabEnv.env * cunify_error + | UnboundConstructor of ErrorMsg.span * string list * string + | PatHasArg of ErrorMsg.span + | PatHasNoArg of ErrorMsg.span + | Inexhaustive of ErrorMsg.span * Elab.pat + | DuplicatePatField of ErrorMsg.span * string + | Unresolvable of ErrorMsg.span * Elab.con + | OutOfContext of ErrorMsg.span * (Elab.exp * Elab.con) option + | IllegalRec of string * Elab.exp + | IllegalFlex of Source.exp + + val expError : ElabEnv.env -> exp_error -> unit + + datatype decl_error = + KunifsRemain of Elab.decl list + | CunifsRemain of Elab.decl list + | Nonpositive of Elab.decl + + val declError : ElabEnv.env -> decl_error -> unit + + datatype sgn_error = + UnboundSgn of ErrorMsg.span * string + | UnmatchedSgi of ErrorMsg.span * Elab.sgn_item + | SgiWrongKind of ErrorMsg.span * Elab.sgn_item * Elab.kind * Elab.sgn_item * Elab.kind * ElabEnv.env * kunify_error + | SgiWrongCon of ErrorMsg.span * Elab.sgn_item * Elab.con * Elab.sgn_item * Elab.con * ElabEnv.env * cunify_error + | SgiMismatchedDatatypes of ErrorMsg.span * Elab.sgn_item * Elab.sgn_item + * (Elab.con * Elab.con * ElabEnv.env * cunify_error) option + | SgnWrongForm of ErrorMsg.span * Elab.sgn * Elab.sgn + | UnWhereable of Elab.sgn * string + | WhereWrongKind of Elab.kind * Elab.kind * ElabEnv.env * kunify_error + | NotIncludable of Elab.sgn + | DuplicateCon of ErrorMsg.span * string + | DuplicateVal of ErrorMsg.span * string + | DuplicateSgn of ErrorMsg.span * string + | DuplicateStr of ErrorMsg.span * string + | NotConstraintsable of Elab.sgn + + val sgnError : ElabEnv.env -> sgn_error -> unit + + datatype str_error = + UnboundStr of ErrorMsg.span * string + | NotFunctor of Elab.sgn + | FunctorRebind of ErrorMsg.span + | UnOpenable of Elab.sgn + | NotType of ErrorMsg.span * Elab.kind * (Elab.kind * Elab.kind * ElabEnv.env * kunify_error) + | DuplicateConstructor of string * ErrorMsg.span + | NotDatatype of ErrorMsg.span + + val strError : ElabEnv.env -> str_error -> unit + +end diff --git a/src/elab_err.sml b/src/elab_err.sml new file mode 100644 index 0000000..385caca --- /dev/null +++ b/src/elab_err.sml @@ -0,0 +1,440 @@ +(* 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. + *) + +structure ElabErr :> ELAB_ERR = struct + +structure L = Source +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +open Print +structure P = ElabPrint + +val p_kind = P.p_kind + +datatype kind_error = + UnboundKind of ErrorMsg.span * string + +fun kindError env err = + case err of + UnboundKind (loc, s) => + ErrorMsg.errorAt loc ("Unbound kind variable " ^ s) + +datatype kunify_error = + KOccursCheckFailed of kind * kind + | KIncompatible of kind * kind + | KScope of kind * kind + +fun kunifyError env err = + case err of + KOccursCheckFailed (k1, k2) => + eprefaces "Kind occurs check failed" + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] + | KIncompatible (k1, k2) => + eprefaces "Incompatible kinds" + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] + | KScope (k1, k2) => + eprefaces "Scoping prevents kind unification" + [("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)] + +fun p_con env c = P.p_con env (ElabOps.reduceCon env c) + +datatype con_error = + UnboundCon of ErrorMsg.span * string + | UnboundDatatype of ErrorMsg.span * string + | UnboundStrInCon of ErrorMsg.span * string + | WrongKind of con * kind * kind * E.env * kunify_error + | DuplicateField of ErrorMsg.span * string + | ProjBounds of con * int + | ProjMismatch of con * kind + +fun conError env err = + case err of + UnboundCon (loc, s) => + ErrorMsg.errorAt loc ("Unbound constructor variable " ^ s) + | UnboundDatatype (loc, s) => + ErrorMsg.errorAt loc ("Unbound datatype " ^ s) + | UnboundStrInCon (loc, 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), + ("Have kind", p_kind env k1), + ("Need kind", p_kind env k2)]; + kunifyError env' kerr) + | DuplicateField (loc, 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), + ("Index", Print.PD.string (Int.toString n))]) + | ProjMismatch (c, k) => + (ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor"; + eprefaces' [("Constructor", p_con env c), + ("Kind", p_kind env k)]) + +datatype cunify_error = + CKind of kind * kind * E.env * kunify_error + | COccursCheckFailed of con * con + | CIncompatible of con * con + | CExplicitness of con * con + | CKindof of kind * con * string + | CRecordFailure of con * con * (con * con * con * (E.env * cunify_error) option) option + | TooLifty of ErrorMsg.span * ErrorMsg.span + | TooUnify of con * con + | TooDeep + | CScope of con * con + +fun cunifyError env err : unit = + case err of + CKind (k1, k2, env', kerr) => + (eprefaces "Kind unification failure" + [("Have", p_kind env k1), + ("Need", p_kind env k2)]; + kunifyError env' kerr) + | COccursCheckFailed (c1, c2) => + eprefaces "Constructor occurs check failed" + [("Have", p_con env c1), + ("Need", p_con env c2)] + | CIncompatible (c1, c2) => + eprefaces "Incompatible constructors" + [("Have", p_con env c1), + ("Need", p_con env c2)] + | CExplicitness (c1, c2) => + eprefaces "Differing constructor function explicitness" + [("Have", p_con env c1), + ("Need", p_con env c2)] + | CKindof (k, c, expected) => + eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")") + [("Kind", p_kind env k), + ("Con", p_con env c)] + | CRecordFailure (c1, c2, fo) => + (eprefaces "Can't unify record constructors" + (("Have", p_con env c1) + :: ("Need", p_con env c2) + :: (case fo of + NONE => [] + | SOME (nm, t1, t2, _) => + [("Field", p_con env nm), + ("Value 1", p_con env t1), + ("Value 2", p_con env t2)])); + case fo of + SOME (_, _, _, SOME (env', err')) => cunifyError env' err' + | _ => ()) + | TooLifty (loc1, loc2) => + (ErrorMsg.errorAt loc1 "Can't unify two unification variables that both have suspended liftings"; + eprefaces' [("Other location", Print.PD.string (ErrorMsg.spanToString loc2))]) + | TooUnify (c1, c2) => + (ErrorMsg.errorAt (#2 c1) "Substitution in constructor is blocked by a too-deep unification variable"; + eprefaces' [("Replacement", p_con env c1), + ("Body", p_con env c2)]) + | TooDeep => ErrorMsg.error "Can't reverse-engineer unification variable lifting" + | CScope (c1, c2) => + eprefaces "Scoping prevents constructor unification" + [("Have", p_con env c1), + ("Need", p_con env c2)] + +datatype exp_error = + UnboundExp of ErrorMsg.span * string + | UnboundStrInExp of ErrorMsg.span * string + | Unify of exp * con * con * E.env * cunify_error + | Unif of string * ErrorMsg.span * con + | WrongForm of string * exp * con + | IncompatibleCons of con * con + | DuplicatePatternVariable of ErrorMsg.span * string + | PatUnify of pat * con * con * E.env * cunify_error + | UnboundConstructor of ErrorMsg.span * string list * string + | PatHasArg of ErrorMsg.span + | PatHasNoArg of ErrorMsg.span + | Inexhaustive of ErrorMsg.span * pat + | DuplicatePatField of ErrorMsg.span * string + | Unresolvable of ErrorMsg.span * con + | OutOfContext of ErrorMsg.span * (exp * con) option + | IllegalRec of string * exp + | IllegalFlex of Source.exp + +val simplExp = U.Exp.mapB {kind = fn _ => fn k => k, + con = fn env => fn c => #1 (ElabOps.reduceCon env (c, ErrorMsg.dummySpan)), + exp = fn _ => fn e => e, + bind = fn (env, U.Exp.RelC (x, k)) => E.pushCRel env x k + | (env, U.Exp.NamedC (x, n, k, co)) => E.pushCNamedAs env x n k co + | (env, _) => env} + +fun p_exp env e = P.p_exp env (simplExp env e) +val p_pat = P.p_pat + +fun expError env err = + case err of + UnboundExp (loc, s) => + ErrorMsg.errorAt loc ("Unbound expression variable " ^ s) + | UnboundStrInExp (loc, 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), + ("Have con", p_con env c1), + ("Need con", p_con env c2)]; + cunifyError env' uerr) + | Unif (action, loc, c) => + (ErrorMsg.errorAt loc ("Unification variable blocks " ^ action); + eprefaces' [("Con", p_con env c)]) + | WrongForm (variety, e, t) => + (ErrorMsg.errorAt (#2 e) ("Expression is not a " ^ variety); + eprefaces' [("Expression", p_exp env e), + ("Type", p_con env t)]) + | IncompatibleCons (c1, c2) => + (ErrorMsg.errorAt (#2 c1) "Incompatible constructors"; + eprefaces' [("Have", p_con env c1), + ("Need", p_con env c2)]) + | DuplicatePatternVariable (loc, 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), + ("Have con", p_con env c1), + ("Need con", p_con env c2)]; + cunifyError env' uerr) + | UnboundConstructor (loc, ms, s) => + ErrorMsg.errorAt loc ("Unbound constructor " ^ String.concatWith "." (ms @ [s]) ^ " in pattern") + | PatHasArg loc => + ErrorMsg.errorAt loc "Constructor expects no argument but is used with argument" + | PatHasNoArg loc => + ErrorMsg.errorAt loc "Constructor expects argument but is used with no argument" + | Inexhaustive (loc, p) => + (ErrorMsg.errorAt loc "Inexhaustive 'case'"; + eprefaces' [("Missed case", p_pat env p)]) + | DuplicatePatField (loc, s) => + ErrorMsg.errorAt loc ("Duplicate record field " ^ s ^ " in pattern") + | OutOfContext (loc, co) => + (ErrorMsg.errorAt loc "Type class wildcard occurs out of context"; + Option.app (fn (e, c) => eprefaces' [("Function", p_exp env e), + ("Type", p_con env c)]) co) + | Unresolvable (loc, c) => + (ErrorMsg.errorAt loc "Can't resolve type class instance"; + eprefaces' ([("Class constraint", p_con env c)] + @ (case E.resolveFailureCause () of + NONE => [] + | SOME c' => [("Reduced to unresolvable", p_con env c')]))(*; + app (fn (c, rs) => (eprefaces' [("CLASS", p_con env c)]; + app (fn (c, e) => eprefaces' [("RULE", p_con env c), + ("IMPL", p_exp env e)]) rs)) + (E.listClasses env)*)) + | IllegalRec (x, e) => + (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)"; + eprefaces' [("Variable", PD.string x), + ("Expression", p_exp env e)]) + | IllegalFlex e => + (ErrorMsg.errorAt (#2 e) "Flex record syntax (\"...\") only allowed in patterns"; + eprefaces' [("Expression", SourcePrint.p_exp e)]) + + +datatype decl_error = + KunifsRemain of decl list + | CunifsRemain of decl list + | Nonpositive of decl + +fun lspan [] = ErrorMsg.dummySpan + | lspan ((_, loc) :: _) = loc + +val baseLen = 2000 + +fun p_decl env d = + let + val fname = OS.FileSys.tmpName () + val out' = TextIO.openOut fname + val out = Print.openOut {dst = out', wid = 80} + + fun readFromFile () = + let + val inf = FileIO.txtOpenIn fname + + fun loop acc = + case TextIO.inputLine inf of + NONE => String.concat (rev acc) + | SOME line => loop (line :: acc) + in + loop [] + before TextIO.closeIn inf + end + in + Print.fprint out (P.p_decl env d); + TextIO.closeOut out'; + let + val content = readFromFile () + in + OS.FileSys.remove fname; + Print.PD.string (if size content <= baseLen then + content + else + let + val (befor, after) = Substring.position "<UNIF:" (Substring.full content) + in + if Substring.isEmpty after then + raise Fail "No unification variables in rendering" + else + Substring.concat [Substring.full "\n.....\n", + if Substring.size befor <= baseLen then + befor + else + Substring.slice (befor, Substring.size befor - baseLen, SOME baseLen), + if Substring.size after <= baseLen then + after + else + Substring.slice (after, 0, SOME baseLen), + Substring.full "\n.....\n"] + end) + end + end + +fun declError env err = + case err of + KunifsRemain ds => + (ErrorMsg.errorAt (lspan ds) "Some kind unification variables are undetermined in declaration\n(look for them as \"<UNIF:...>\")"; + eprefaces' [("Decl", p_list_sep PD.newline (p_decl env) ds)]) + | CunifsRemain ds => + (ErrorMsg.errorAt (lspan ds) "Some constructor unification variables are undetermined in declaration\n(look for them as \"<UNIF:...>\")"; + eprefaces' [("Decl", p_list_sep PD.newline (p_decl env) ds)]) + | Nonpositive d => + (ErrorMsg.errorAt (#2 d) "Non-strictly-positive datatype declaration (could allow non-termination)"; + eprefaces' [("Decl", p_decl env d)]) + +datatype sgn_error = + UnboundSgn of ErrorMsg.span * string + | UnmatchedSgi of ErrorMsg.span * sgn_item + | SgiWrongKind of ErrorMsg.span * sgn_item * kind * sgn_item * kind * E.env * kunify_error + | SgiWrongCon of ErrorMsg.span * sgn_item * con * sgn_item * con * E.env * cunify_error + | SgiMismatchedDatatypes of ErrorMsg.span * sgn_item * sgn_item + * (con * con * E.env * cunify_error) option + | SgnWrongForm of ErrorMsg.span * sgn * sgn + | UnWhereable of sgn * string + | WhereWrongKind of kind * kind * E.env * kunify_error + | NotIncludable of sgn + | DuplicateCon of ErrorMsg.span * string + | DuplicateVal of ErrorMsg.span * string + | DuplicateSgn of ErrorMsg.span * string + | DuplicateStr of ErrorMsg.span * string + | NotConstraintsable of sgn + +val p_sgn_item = P.p_sgn_item +val p_sgn = P.p_sgn + +fun sgnError env err = + case err of + UnboundSgn (loc, s) => + ErrorMsg.errorAt loc ("Unbound signature variable " ^ s) + | UnmatchedSgi (loc, sgi) => + (ErrorMsg.errorAt loc "Unmatched signature item"; + eprefaces' [("Item", p_sgn_item env sgi)]) + | SgiWrongKind (loc, sgi1, k1, sgi2, k2, env', kerr) => + (ErrorMsg.errorAt loc "Kind unification failure in signature matching:"; + eprefaces' [("Have", p_sgn_item env sgi1), + ("Need", p_sgn_item env sgi2), + ("Kind 1", p_kind env k1), + ("Kind 2", p_kind env k2)]; + kunifyError env' kerr) + | SgiWrongCon (loc, sgi1, c1, sgi2, c2, env', cerr) => + (ErrorMsg.errorAt loc "Constructor unification failure in signature matching:"; + eprefaces' [("Have", p_sgn_item env sgi1), + ("Need", p_sgn_item env sgi2), + ("Con 1", p_con env c1), + ("Con 2", p_con env c2)]; + cunifyError env' cerr) + | SgiMismatchedDatatypes (loc, sgi1, sgi2, cerro) => + (ErrorMsg.errorAt loc "Mismatched 'datatype' specifications:"; + eprefaces' [("Have", p_sgn_item env sgi1), + ("Need", p_sgn_item env sgi2)]; + Option.app (fn (c1, c2, env', ue) => + (eprefaces "Unification error" + [("Con 1", p_con env' c1), + ("Con 2", p_con env' c2)]; + cunifyError env' ue)) cerro) + | SgnWrongForm (loc, sgn1, sgn2) => + (ErrorMsg.errorAt loc "Incompatible signatures:"; + eprefaces' [("Sig 1", p_sgn env sgn1), + ("Sig 2", p_sgn env sgn2)]) + | UnWhereable (sgn, x) => + (ErrorMsg.errorAt (#2 sgn) "Unavailable field for 'where'"; + eprefaces' [("Signature", p_sgn env sgn), + ("Field", PD.string x)]) + | WhereWrongKind (k1, k2, env', kerr) => + (ErrorMsg.errorAt (#2 k1) "Wrong kind for 'where'"; + eprefaces' [("Have", p_kind env k1), + ("Need", p_kind env k2)]; + kunifyError env' kerr) + | NotIncludable sgn => + (ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'"; + eprefaces' [("Signature", p_sgn env sgn)]) + | DuplicateCon (loc, s) => + ErrorMsg.errorAt loc ("Duplicate constructor " ^ s ^ " in signature") + | DuplicateVal (loc, s) => + ErrorMsg.errorAt loc ("Duplicate value " ^ s ^ " in signature") + | DuplicateSgn (loc, s) => + ErrorMsg.errorAt loc ("Duplicate signature " ^ s ^ " in signature") + | DuplicateStr (loc, s) => + ErrorMsg.errorAt loc ("Duplicate structure " ^ s ^ " in signature") + | NotConstraintsable sgn => + (ErrorMsg.errorAt (#2 sgn) "Invalid signature for 'open constraints'"; + eprefaces' [("Signature", p_sgn env sgn)]) + +datatype str_error = + UnboundStr of ErrorMsg.span * string + | NotFunctor of sgn + | FunctorRebind of ErrorMsg.span + | UnOpenable of sgn + | NotType of ErrorMsg.span * kind * (kind * kind * E.env * kunify_error) + | DuplicateConstructor of string * ErrorMsg.span + | NotDatatype of ErrorMsg.span + +fun strError env err = + case err of + UnboundStr (loc, s) => + ErrorMsg.errorAt loc ("Unbound structure variable " ^ s) + | NotFunctor sgn => + (ErrorMsg.errorAt (#2 sgn) "Application of non-functor"; + eprefaces' [("Signature", p_sgn env sgn)]) + | FunctorRebind loc => + ErrorMsg.errorAt loc "Attempt to rebind functor" + | UnOpenable sgn => + (ErrorMsg.errorAt (#2 sgn) "Un-openable structure"; + eprefaces' [("Signature", p_sgn env sgn)]) + | NotType (loc, k, (k1, k2, env', ue)) => + (ErrorMsg.errorAt loc "'val' type kind is not 'Type'"; + eprefaces' [("Kind", p_kind env k), + ("Subkind 1", p_kind env k1), + ("Subkind 2", p_kind env k2)]; + kunifyError env' ue) + | DuplicateConstructor (x, loc) => + ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x) + | NotDatatype loc => + ErrorMsg.errorAt loc "Trying to import non-datatype as a datatype" + +end diff --git a/src/elab_ops.sig b/src/elab_ops.sig new file mode 100644 index 0000000..97e4b60 --- /dev/null +++ b/src/elab_ops.sig @@ -0,0 +1,50 @@ +(* Copyright (c) 2008, 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 ELAB_OPS = sig + + exception SubUnif + + val liftKindInKind : int -> Elab.kind -> Elab.kind + val subKindInKind : int * Elab.kind -> Elab.kind -> Elab.kind + + val liftKindInCon : int -> Elab.con -> Elab.con + val subKindInCon : int * Elab.kind -> Elab.con -> Elab.con + + val liftConInCon : int -> Elab.con -> Elab.con + val subConInCon : int * Elab.con -> Elab.con -> Elab.con + val subStrInSgn : int * int -> Elab.sgn -> Elab.sgn + + val hnormCon : ElabEnv.env -> Elab.con -> Elab.con + val reduceCon : ElabEnv.env -> Elab.con -> Elab.con + + val identity : int ref + val distribute : int ref + val fuse : int ref + val reset : unit -> unit + +end diff --git a/src/elab_ops.sml b/src/elab_ops.sml new file mode 100644 index 0000000..6ff5e03 --- /dev/null +++ b/src/elab_ops.sml @@ -0,0 +1,517 @@ +(* Copyright (c) 2008, 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 ElabOps :> ELAB_OPS = struct + +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +fun liftKindInKind' by = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + by) + | _ => k, + bind = fn (bound, _) => bound + 1} + +fun subKindInKind' rep = + U.Kind.mapB {kind = fn (by, xn) => fn k => + case k of + KRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftKindInKind' by 0 rep) + | GREATER => KRel (xn' - 1) + | LESS => k) + | _ => k, + bind = fn ((by, xn), _) => (by+1, xn+1)} + +val liftKindInKind = liftKindInKind' 1 + +fun subKindInKind (xn, rep) = subKindInKind' rep (0, xn) + +fun liftKindInCon by = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + by) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + +fun subKindInCon' rep = + U.Con.mapB {kind = fn (by, xn) => fn k => + case k of + KRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftKindInKind' by 0 rep) + | GREATER => KRel (xn' - 1) + | LESS => k) + | _ => k, + con = fn _ => fn c => c, + bind = fn ((by, xn), U.Con.RelK _) => (by+1, xn+1) + | (st, _) => st} + +val liftKindInCon = liftKindInCon 1 + +fun subKindInCon (xn, rep) = subKindInCon' rep (0, xn) + +fun liftConInCon by = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + by) + | CUnif (nl, loc, k, s, r) => CUnif (nl+by, loc, k, s, r) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} + +exception SubUnif + +fun subConInCon' rep = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn (by, xn) => fn c => + case c of + CRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftConInCon by 0 rep) + | GREATER => CRel (xn' - 1) + | LESS => c) + | CUnif (0, _, _, _, _) => raise SubUnif + | CUnif (n, loc, k, s, r) => CUnif (n-1, loc, k, s, r) + | _ => c, + bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1) + | (ctx, _) => ctx} + +val liftConInCon = liftConInCon 1 + +fun subConInCon (xn, rep) = subConInCon' rep (0, xn) + +fun subStrInSgn (m1, m2) = + U.Sgn.map {kind = fn k => k, + con = fn c as CModProj (m1', ms, x) => + if m1 = m1' then + CModProj (m2, ms, x) + else + c + | c => c, + sgn_item = fn sgi => sgi, + sgn = fn sgn => sgn} + +val occurs = + U.Con.existsB {kind = fn _ => false, + con = fn (n, c) => + case c of + CRel n' => n' = n + | _ => false, + bind = fn (n, b) => + case b of + U.Con.RelC _ => n + 1 + | _ => n} + 0 + +val identity = ref 0 +val distribute = ref 0 +val fuse = ref 0 + +fun reset () = (identity := 0; + distribute := 0; + fuse := 0) + +fun hnormCon env (cAll as (c, loc)) = + case c of + CUnif (nl, _, _, _, ref (Known c)) => (#1 (hnormCon env (E.mliftConInCon nl c)), loc) + + | CNamed xn => + (case E.lookupCNamed env xn of + (_, _, SOME c') => hnormCon env c' + | _ => cAll) + + | CModProj (n, ms, x) => + let + val (_, sgn) = E.lookupStrNamed env n + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "hnormCon: Unknown substructure" + | SOME sgn => ((StrProj (str, m), loc), sgn)) + ((StrVar n, loc), sgn) ms + in + case E.projectCon env {sgn = sgn, str = str, field = x} of + NONE => raise Fail "kindof: Unknown con in structure" + | SOME (_, NONE) => cAll + | SOME (_, SOME c) => hnormCon env c + end + + (* Eta reduction *) + | CAbs (x, k, b) => + (case #1 (hnormCon (E.pushCRel env x k) b) of + CApp (f, (CRel 0, _)) => + if occurs f then + cAll + else + hnormCon env (subConInCon (0, (CUnit, loc)) f) + | _ => cAll) + + | CApp (c1, c2) => + (case #1 (hnormCon env c1) of + CAbs (x, k, cb) => + let + val sc = (hnormCon env (subConInCon (0, c2) cb)) + handle SynUnif => cAll + (*val env' = E.pushCRel env x k*) + in + (*Print.eprefaces "Subst" [("x", Print.PD.string x), + ("cb", ElabPrint.p_con env' cb), + ("c2", ElabPrint.p_con env c2), + ("sc", ElabPrint.p_con env sc)];*) + sc + end + | c1' as CApp (c', f) => + let + fun default () = (CApp ((c1', loc), hnormCon env c2), loc) + in + case #1 (hnormCon env c') of + CMap (ks as (k1, k2)) => + (case #1 (hnormCon env c2) of + CRecord (_, []) => (CRecord (k2, []), loc) + | CRecord (_, (x, c) :: rest) => + hnormCon env + (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, (CRecord (k2, rest), loc)), loc)), loc) + | CConcat ((CRecord (k, (x, c) :: rest), _), rest') => + let + val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc) + in + hnormCon env + (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, rest''), loc)), loc) + end + | _ => + let + fun unconstraint c = + case hnormCon env c of + (TDisjoint (_, _, c), _) => unconstraint c + | c => c + + fun inc r = r := !r + 1 + + fun tryDistributivity () = + case hnormCon env c2 of + (CConcat (c1, c2'), _) => + let + val c = (CMap ks, loc) + val c = (CApp (c, f), loc) + + val c1 = (CApp (c, c1), loc) + val c2 = (CApp (c, c2'), loc) + val c = (CConcat (c1, c2), loc) + in + inc distribute; + hnormCon env c + end + | _ => default () + + fun tryFusion () = + case #1 (hnormCon env c2) of + CApp (f', r') => + (case #1 (hnormCon env f') of + CApp (f', inner_f) => + (case #1 (hnormCon env f') of + CMap (dom, _) => + let + val inner_f = liftConInCon 0 inner_f + val f = liftConInCon 0 f + + val f' = (CApp (inner_f, (CRel 0, loc)), loc) + val f' = (CApp (f, f'), loc) + val f' = (CAbs ("v", dom, f'), loc) + + val c = (CMap (dom, k2), loc) + val c = (CApp (c, f'), loc) + val c = (CApp (c, r'), loc) + in + inc fuse; + hnormCon env c + end + | _ => tryDistributivity ()) + | _ => tryDistributivity ()) + | _ => tryDistributivity () + + fun tryIdentity () = + let + fun cunif () = + let + val r = ref (Unknown (fn _ => true)) + in + (r, (CUnif (0, loc, (KType, loc), "_", r), loc)) + end + + val (vR, v) = cunif () + + val c = (CApp (f, v), loc) + in + case unconstraint c of + (CUnif (_, _, _, _, vR'), _) => + if vR' = vR then + (inc identity; + hnormCon env c2) + else + tryFusion () + | _ => tryFusion () + end + in + tryIdentity () + end) + | _ => default () + end + | c1' => (CApp ((c1', loc), hnormCon env c2), loc)) + + | CKApp (c1, k) => + (case hnormCon env c1 of + (CKAbs (_, body), _) => hnormCon env (subKindInCon (0, k) body) + | _ => cAll) + + | CConcat (c1, c2) => + (case (hnormCon env c1, hnormCon env c2) of + ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => + (CRecord (k, xcs1 @ xcs2), loc) + | ((CRecord (_, []), _), c2') => c2' + | ((CConcat (c11, c12), loc), c2') => + hnormCon env (CConcat (c11, (CConcat (c12, c2'), loc)), loc) + | (c1', (CRecord (_, []), _)) => c1' + | (c1', c2') => (CConcat (c1', c2'), loc)) + + | CProj (c, n) => + (case hnormCon env c of + (CTuple cs, _) => hnormCon env (List.nth (cs, n - 1)) + | _ => cAll) + + | _ => cAll + +fun reduceCon env (cAll as (c, loc)) = + case c of + TFun (c1, c2) => (TFun (reduceCon env c1, reduceCon env c2), loc) + | TCFun (exp, x, k, c) => (TCFun (exp, x, k, reduceCon env c), loc) + | TRecord c => (TRecord (reduceCon env c), loc) + | TDisjoint (c1, c2, c3) => (TDisjoint (reduceCon env c1, reduceCon env c2, reduceCon env c3), loc) + + | CRel _ => cAll + | CNamed xn => + (case E.lookupCNamed env xn of + (_, _, SOME c') => reduceCon env c' + | _ => cAll) + | CModProj (n, ms, x) => + let + val (_, sgn) = E.lookupStrNamed env n + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "reduceCon: Unknown substructure" + | SOME sgn => ((StrProj (str, m), loc), sgn)) + ((StrVar n, loc), sgn) ms + in + case E.projectCon env {sgn = sgn, str = str, field = x} of + NONE => raise Fail "reduceCon: kindof: Unknown con in structure" + | SOME (_, NONE) => cAll + | SOME (_, SOME c) => reduceCon env c + end + + | CApp (c1, c2) => + let + val c1 = reduceCon env c1 + val c2 = reduceCon env c2 + fun default () = (CApp (c1, c2), loc) + in + case #1 c1 of + CAbs (x, k, cb) => + ((reduceCon env (subConInCon (0, c2) cb)) + handle SynUnif => default ()) + | CApp (c', f) => + let + val c' = reduceCon env c' + val f = reduceCon env f + in + case #1 c' of + CMap (ks as (k1, k2)) => + (case #1 c2 of + CRecord (_, []) => (CRecord (k2, []), loc) + | CRecord (_, (x, c) :: rest) => + reduceCon env + (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, (CRecord (k2, rest), loc)), loc)), loc) + | CConcat ((CRecord (k, (x, c) :: rest), _), rest') => + let + val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc) + in + reduceCon env + (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, rest''), loc)), loc) + end + | _ => + let + fun unconstraint c = + case reduceCon env c of + (TDisjoint (_, _, c), _) => unconstraint c + | c => c + + fun inc r = r := !r + 1 + + fun tryDistributivity () = + case reduceCon env c2 of + (CConcat (c1, c2), _) => + let + val c = (CMap ks, loc) + val c = (CApp (c, f), loc) + + val c1 = (CApp (c, c1), loc) + val c2 = (CApp (c, c2), loc) + val c = (CConcat (c1, c2), loc) + in + inc distribute; + reduceCon env c + end + | _ => default () + + fun tryFusion () = + case #1 (reduceCon env c2) of + CApp (f', r') => + (case #1 (reduceCon env f') of + CApp (f', inner_f) => + (case #1 (reduceCon env f') of + CMap (dom, _) => + let + val inner_f = liftConInCon 0 inner_f + val f = liftConInCon 0 f + + val f' = (CApp (inner_f, (CRel 0, loc)), loc) + val f' = (CApp (f, f'), loc) + val f' = (CAbs ("v", dom, f'), loc) + + val c = (CMap (dom, k2), loc) + val c = (CApp (c, f'), loc) + val c = (CApp (c, r'), loc) + in + inc fuse; + reduceCon env c + end + | _ => tryDistributivity ()) + | _ => tryDistributivity ()) + | _ => tryDistributivity () + + fun tryIdentity () = + let + fun cunif () = + let + val r = ref (Unknown (fn _ => true)) + in + (r, (CUnif (0, loc, (KType, loc), "_", r), loc)) + end + + val (vR, v) = cunif () + + val c = (CApp (f, v), loc) + in + case unconstraint c of + (CUnif (_, _, _, _, vR'), _) => + if vR' = vR then + (inc identity; + reduceCon env c2) + else + tryFusion () + | _ => tryFusion () + end + in + tryIdentity () + end) + | _ => default () + end + | _ => default () + end + | CAbs (x, k, b) => + let + val b = reduceCon (E.pushCRel env x k) b + fun default () = (CAbs (x, k, b), loc) + in + case #1 b of + CApp (f, (CRel 0, _)) => + if occurs f then + default () + else + reduceCon env (subConInCon (0, (CUnit, loc)) f) + | _ => default () + end + + | CKAbs (x, b) => (CKAbs (x, reduceCon (E.pushKRel env x) b), loc) + | CKApp (c1, k) => + (case reduceCon env c1 of + (CKAbs (_, body), _) => reduceCon env (subKindInCon (0, k) body) + | c1 => (CKApp (c1, k), loc)) + | TKFun (x, c) => (TKFun (x, reduceCon env c), loc) + + | CName _ => cAll + + | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (reduceCon env x, reduceCon env c)) xcs), loc) + | CConcat (c1, c2) => + let + val c1 = reduceCon env c1 + val c2 = reduceCon env c2 + in + case (c1, c2) of + ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => (CRecord (k, xcs1 @ xcs2), loc) + | ((CRecord (_, []), _), _) => c2 + | ((CConcat (c11, c12), loc), _) => reduceCon env (CConcat (c11, (CConcat (c12, c2), loc)), loc) + | (_, (CRecord (_, []), _)) => c1 + | ((CRecord (k, xcs1), loc), (CConcat ((CRecord (_, xcs2), _), c2'), _)) => (CConcat ((CRecord (k, xcs1 @ xcs2), loc), c2'), loc) + | _ => (CConcat (c1, c2), loc) + end + | CMap _ => cAll + + | CUnit => cAll + + | CTuple cs => (CTuple (map (reduceCon env) cs), loc) + | CProj (c, n) => + (case reduceCon env c of + (CTuple cs, _) => reduceCon env (List.nth (cs, n - 1)) + | c => (CProj (c, n), loc)) + + | CError => cAll + + | CUnif (nl, _, _, _, ref (Known c)) => reduceCon env (E.mliftConInCon nl c) + | CUnif _ => cAll + +end diff --git a/src/elab_print.sig b/src/elab_print.sig new file mode 100644 index 0000000..1eb832b --- /dev/null +++ b/src/elab_print.sig @@ -0,0 +1,44 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web *) + +signature ELAB_PRINT = sig + val p_kind : ElabEnv.env -> Elab.kind Print.printer + val p_explicitness : Elab.explicitness Print.printer + val p_con : ElabEnv.env -> Elab.con Print.printer + val p_pat : ElabEnv.env -> Elab.pat Print.printer + val p_exp : ElabEnv.env -> Elab.exp Print.printer + val p_decl : ElabEnv.env -> Elab.decl Print.printer + val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer + 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 new file mode 100644 index 0000000..8a6a651 --- /dev/null +++ b/src/elab_print.sml @@ -0,0 +1,906 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing elaborated Ur/Web *) + +structure ElabPrint :> ELAB_PRINT = struct + +open Print.PD +open Print + +open Elab + +structure E = ElabEnv + +val debug = ref false + +fun p_kind' par env (k, _) = + case k of + KType => string "Type" + | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, + space, + string "->", + space, + p_kind env k2]) + | KName => string "Name" + | KRecord k => box [string "{", p_kind env k, string "}"] + | KUnit => string "Unit" + | KTuple ks => box [string "(", + p_list_sep (box [space, string "*", space]) (p_kind env) ks, + string ")"] + + | KError => string "<ERROR>" + | KUnif (_, _, ref (KKnown k)) => p_kind' par env k + | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">") + | KTupleUnif (_, _, ref (KKnown k)) => p_kind' par env k + | KTupleUnif (_, nks, _) => box [string "(", + p_list_sep (box [space, string "*", space]) + (fn (n, k) => box [string (Int.toString n ^ ":"), + space, + p_kind env k]) nks, + space, + string "*", + space, + string "...)"] + + | KRel n => ((if !debug then + string (E.lookupKRel env n ^ "_" ^ Int.toString n) + else + string (E.lookupKRel env n)) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind (E.pushKRel env x) k] + +and p_kind env = p_kind' false env + +fun p_explicitness e = + case e of + Explicit => string "::" + | Implicit => string ":::" + +fun p_con' par env (c, _) = + case c of + TFun (t1, t2) => parenIf par (box [p_con' true env t1, + space, + string "->", + space, + p_con env t2]) + | TCFun (e, x, k, c) => parenIf par (box [string x, + space, + p_explicitness e, + space, + p_kind env k, + space, + string "->", + space, + p_con (E.pushCRel env x k) c]) + | TDisjoint (c1, c2, c3) => parenIf par (box [string "[", + p_con env c1, + space, + string "~", + space, + p_con env c2, + string "]", + space, + string "=>", + space, + p_con env c3]) + | TRecord (CRecord (_, xcs), _) => + let + fun isTuple (n, xcs) = + case xcs of + [] => n > 2 + | ((CName s, _), _) :: xcs' => + s = Int.toString n andalso isTuple (n+1, xcs') + | _ => false + in + if isTuple (1, xcs) then + case xcs of + (_, c) :: xcs => + parenIf par (box [p_con' true env c, + p_list_sep (box []) (fn (_, c) => box [space, + string "*", + space, + p_con' true env c]) xcs]) + | _ => raise Fail "ElabPrint: surprise empty tuple" + else + box [string "{", + p_list (fn (x, c) => + box [p_name env x, + space, + string ":", + space, + p_con env c]) xcs, + string "}"] + end + | TRecord c => box [string "$", + p_con' true env c] + + | CRel n => + ((if !debug then + string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupCRel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | CNamed n => + ((if !debug then + string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupCNamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | CModProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + if m1x = "Basis" andalso (case E.lookupC env x of + E.Named (n, _) => + let + val (_, _, co) = E.lookupCNamed env n + in + case co of + SOME (CModProj (m1', [], x'), _) => m1' = m1 andalso x' = x + | _ => false + end + | E.NotBound => true + | _ => false) then + string x + else + p_list_sep (string ".") string (m1s :: ms @ [x]) + end + + | CApp (c1, c2) => parenIf par (box [p_con env c1, + space, + p_con' true env c2]) + | CAbs (x, k, c) => parenIf true (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind env k, + space, + string "=>", + space, + p_con (E.pushCRel env x k) c]) + + | CName s => box [string "#", string s] + + | CRecord (k, xcs) => + if !debug then + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_name env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]::", + p_kind env k]) + else + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_name env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]"]) + | CConcat (c1, c2) => parenIf par (box [p_con' true env c1, + space, + string "++", + space, + p_con env c2]) + | CMap _ => string "map" + + | CUnit => string "()" + + | CTuple cs => box [string "(", + p_list (p_con env) cs, + string ")"] + | CProj (c, n) => box [p_con env c, + string ".", + string (Int.toString n)] + + | CError => string "<ERROR>" + | CUnif (nl, _, _, _, ref (Known c)) => p_con' par env (E.mliftConInCon nl c) + | CUnif (nl, _, k, s, _) => box [string ("<UNIF:" ^ s ^ "::"), + p_kind env k, + case nl of + 0 => box [] + | _ => string ("+" ^ Int.toString nl), + string ">"] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con (E.pushKRel env x) c] + | CKApp (c, k) => box [p_con env c, + string "[[", + p_kind env k, + string "]]"] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con (E.pushKRel env x) c] + + +and p_con env = p_con' false env + +and p_name env (all as (c, _)) = + case c of + CName s => string s + | _ => p_con env all + +fun p_patCon env pc = + case pc of + PConVar n => + ((if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | PConProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1x :: ms @ [x]) + end + +fun p_pat' par env (p, _) = + case p of + PVar (s, _) => string s + | PPrim p => Prim.p_t p + | PCon (_, pc, _, NONE) => p_patCon env pc + | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc, + space, + p_pat' true env p]) + | PRecord xps => + box [string "{", + p_list_sep (box [string ",", space]) (fn (x, p, t) => + box [string x, + space, + string "=", + space, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, + string "}"] + +and p_pat x = p_pat' false x + +fun p_exp' par env (e, _) = + case e of + EPrim p => Prim.p_t p + | ERel n => + ((if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | ENamed n => + ((if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | EModProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1x :: ms @ [x]) + end + + | EApp (e1, e2) => parenIf par (box [p_exp env e1, + space, + p_exp' true env e2]) + | EAbs (x, t, _, e) => parenIf par (box [string "fn", + space, + string x, + space, + string ":", + space, + p_con env t, + space, + string "=>", + space, + p_exp (E.pushERel env x t) e]) + | ECApp (e, c) => parenIf par (box [p_exp env e, + space, + string "[", + p_con env c, + string "]"]) + | ECAbs (exp, x, k, e) => parenIf par (box [string "fn", + space, + string x, + space, + p_explicitness exp, + space, + p_kind env k, + space, + string "=>", + space, + p_exp (E.pushCRel env x k) e]) + + | ERecord xes => box [string "{", + p_list (fn (x, e, _) => + box [p_name env x, + space, + string "=", + space, + p_exp env e]) xes, + string "}"] + | EField (e, c, {field, rest}) => + if !debug then + box [p_exp' true env e, + string ".", + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + string ".", + p_con' true env c] + | EConcat (e1, c1, e2, c2) => + parenIf par (if !debug then + box [p_exp' true env e1, + space, + string ":", + space, + p_con env c1, + space, + string "++", + space, + p_exp' true env e2, + space, + string ":", + space, + p_con env c2] + else + box [p_exp' true env e1, + space, + string "++", + space, + p_exp' true env e2]) + | ECut (e, c, {field, rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) + + | ECase (e, pes, _) => parenIf par (box [string "case", + space, + p_exp env e, + space, + string "of", + space, + p_list_sep (box [space, string "|", space]) + (fn (p, e) => box [p_pat env p, + space, + string "=>", + space, + p_exp (E.patBinds env p) e]) pes]) + + | EError => string "<ERROR>" + | EUnif (ref (SOME e)) => p_exp env e + | EUnif _ => string "_" + + | ELet (ds, e, _) => + let + val (dsp, env) = ListUtil.foldlMap + (fn (d, env) => + (p_edecl env d, + E.edeclBinds env d)) + env ds + in + box [string "let", + newline, + box [p_list_sep newline (fn x => x) dsp], + newline, + string "in", + newline, + box [p_exp env e], + newline, + string "end"] + end + + | EKAbs (x, e) => box [string x, + space, + string "==>", + space, + p_exp (E.pushKRel env x) e] + | EKApp (e, k) => box [p_exp env e, + string "[[", + p_kind env k, + string "]]"] + +and p_exp env = p_exp' false env + +and p_edecl env (dAll as (d, _)) = + case d of + EDVal (p, t, e) => box [string "val", + space, + p_pat env p, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + | EDValRec vis => + let + val env = E.edeclBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_evali env) vis] + end + +and p_evali env (x, t, e) = box [string x, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + +fun p_datatype env (x, n, xs, cons) = + let + val k = (KType, ErrorMsg.dummySpan) + 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, + p_list_sep (box []) (fn x => box [space, string x]) xs, + space, + string "=", + space, + p_list_sep (box [space, string "|", space]) + (fn (x, _, NONE) => string x + | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t]) + cons] + end + +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + +fun p_sgn_item env (sgiAll as (sgi, _)) = + case sgi of + SgiConAbs (x, n, k) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k] + | SgiCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + | SgiDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x] + | SgiDatatypeImp (x, _, m1, ms, x', _, _) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + in + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (m1x :: ms @ [x'])] + end + | SgiVal (x, n, c) => box [string "val", + space, + p_named x n, + space, + string ":", + space, + p_con env c] + | SgiStr (_, x, n, sgn) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] + | SgiSgn (x, n, sgn) => box [string "signature", + space, + p_named x n, + space, + string "=", + space, + p_sgn env sgn] + | SgiConstraint (c1, c2) => box [string "constraint", + space, + p_con env c1, + space, + string "~", + space, + p_con env c2] + | SgiClassAbs (x, n, k) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind env k] + | SgiClass (x, n, k, c) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + +and p_sgn env (sgn, _) = + case sgn of + SgnConst sgis => box [string "sig", + newline, + let + val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) => + (p_sgn_item env sgi, + E.sgiBinds env sgi)) + env sgis + in + p_list_sep newline (fn x => x) psgis + end, + newline, + string "end"] + | SgnVar n => ((string (#1 (E.lookupSgnNamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n)) + | SgnFun (x, n, sgn, sgn') => box [string "functor", + space, + string "(", + string x, + space, + string ":", + space, + p_sgn env sgn, + string ")", + space, + string ":", + space, + p_sgn (E.pushStrNamedAs' false env x n sgn) sgn'] + | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, + space, + string "where", + space, + string "con", + space, + p_list_sep (string ".") string (ms @ [x]), + space, + string "=", + space, + p_con env c] + | SgnProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1 + + val m1x = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1x :: ms @ [x]) + end + | SgnError => string "<ERROR>" + +fun p_vali env (x, n, t, e) = box [p_named x n, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + + + +fun p_decl env (dAll as (d, _) : decl) = + case d of + DCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] + | DDatatypeImp (x, _, m1, ms, x', _, _) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + in + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (m1x :: ms @ [x'])] + end + | DVal vi => box [string "val", + space, + p_vali env vi] + | DValRec vis => + let + val env = E.declBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_vali env) vis] + end + + | DSgn (x, n, sgn) => box [string "signature", + space, + p_named x n, + space, + string "=", + space, + p_sgn env sgn] + | DStr (x, n, sgn, str) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn, + space, + string "=", + space, + p_str env str] + | DFfiStr (x, n, sgn) => box [string "extern", + space, + string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] + | DConstraint (c1, c2) => box [string "constraint", + space, + p_con env c1, + space, + string "~", + space, + p_con env c2] + | DExport (_, sgn, str) => box [string "export", + space, + p_str env str, + space, + string ":", + space, + p_sgn env sgn] + | DTable (_, x, n, c, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce] + | DSequence (_, x, n) => box [string "sequence", + space, + p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] + | DDatabase s => box [string "database", + space, + string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] + | DTask (e1, e2) => box [string "task", + space, + p_exp env e1, + space, + string "=", + space, + p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] + | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" + +and p_str env (str, _) = + case str of + StrConst ds => box [string "struct", + newline, + p_file env ds, + newline, + string "end"] + | StrVar n => ((string (#1 (E.lookupStrNamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n)) + | StrProj (str, s) => box [p_str env str, + string ".", + string s] + | StrFun (x, n, sgn, sgn', str) => + let + val env' = E.pushStrNamedAs' false env x n sgn + in + box [string "functor", + space, + string "(", + string x, + space, + string ":", + space, + p_sgn env sgn, + string ")", + space, + string ":", + space, + p_sgn env' sgn', + space, + string "=>", + space, + p_str env' str] + end + | StrApp (str1, str2) => box [p_str env str1, + string "(", + p_str env str2, + string ")"] + | StrError => string "<ERROR>" + +and p_file env file = + let + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) + env file + in + p_list_sep newline (fn x => x) pds + end + +end diff --git a/src/elab_util.sig b/src/elab_util.sig new file mode 100644 index 0000000..dc07f6f --- /dev/null +++ b/src/elab_util.sig @@ -0,0 +1,257 @@ +(* 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. + *) + +signature ELAB_UTIL = sig + +val classifyDatatype : (string * int * 'a option) list -> Elab.datatype_kind + +val mliftConInCon : (int -> Elab.con -> Elab.con) ref + +structure Kind : sig + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + bind : 'context * string -> 'context} + -> ('context, Elab.kind, 'state, 'abort) Search.mapfolderB + val mapfold : (Elab.kind', 'state, 'abort) Search.mapfolder + -> (Elab.kind, 'state, 'abort) Search.mapfolder + val exists : (Elab.kind' -> bool) -> Elab.kind -> bool + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + bind : 'context * string -> 'context} + -> 'context -> (Elab.kind -> Elab.kind) + val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, + bind : 'context * string -> 'context} + -> 'context -> 'state -> Elab.kind -> 'state +end + +structure Con : sig + datatype binder = + RelK of string + | RelC of string * Elab.kind + | NamedC of string * int * Elab.kind * Elab.con option + + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Elab.con, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + con : (Elab.con', 'state, 'abort) Search.mapfolder} + -> (Elab.con, 'state, 'abort) Search.mapfolder + + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + con : 'context -> Elab.con' -> Elab.con', + bind : 'context * binder -> 'context} + -> 'context -> (Elab.con -> Elab.con) + val map : {kind : Elab.kind' -> Elab.kind', + con : Elab.con' -> Elab.con'} + -> Elab.con -> Elab.con + val appB : {kind : 'context -> Elab.kind' -> unit, + con : 'context -> Elab.con' -> unit, + bind : 'context * binder -> 'context} + -> 'context -> (Elab.con -> unit) + val app : {kind : Elab.kind' -> unit, + con : Elab.con' -> unit} + -> Elab.con -> unit + val existsB : {kind : 'context * Elab.kind' -> bool, + con : 'context * Elab.con' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Elab.con -> bool + val exists : {kind : Elab.kind' -> bool, + con : Elab.con' -> bool} -> Elab.con -> bool + + val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.con -> 'state + val fold : {kind : Elab.kind' * 'state -> 'state, + con : Elab.con' * 'state -> 'state} + -> 'state -> Elab.con -> 'state +end + +structure Exp : 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 + + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Elab.exp, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + con : (Elab.con', 'state, 'abort) Search.mapfolder, + exp : (Elab.exp', 'state, 'abort) Search.mapfolder} + -> (Elab.exp, 'state, 'abort) Search.mapfolder + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + con : 'context -> Elab.con' -> Elab.con', + exp : 'context -> Elab.exp' -> Elab.exp', + bind : 'context * binder -> 'context} + -> 'context -> (Elab.exp -> Elab.exp) + val exists : {kind : Elab.kind' -> bool, + con : Elab.con' -> bool, + exp : Elab.exp' -> bool} -> Elab.exp -> bool + val existsB : {kind : 'context * Elab.kind' -> bool, + con : 'context * Elab.con' -> bool, + exp : 'context * Elab.exp' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Elab.exp -> bool + + val foldB : {kind : 'context * Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + exp : 'context * Elab.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.exp -> 'state +end + +structure Sgn : sig + 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 + + val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, + sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB, + sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Elab.sgn, 'state, 'abort) Search.mapfolderB + + + val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + con : (Elab.con', 'state, 'abort) Search.mapfolder, + sgn_item : (Elab.sgn_item', 'state, 'abort) Search.mapfolder, + sgn : (Elab.sgn', 'state, 'abort) Search.mapfolder} + -> (Elab.sgn, 'state, 'abort) Search.mapfolder + + val map : {kind : Elab.kind' -> Elab.kind', + con : Elab.con' -> Elab.con', + sgn_item : Elab.sgn_item' -> Elab.sgn_item', + sgn : Elab.sgn' -> Elab.sgn'} + -> Elab.sgn -> Elab.sgn + + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + con : 'context -> Elab.con' -> Elab.con', + sgn_item : 'context -> Elab.sgn_item' -> Elab.sgn_item', + sgn : 'context -> Elab.sgn' -> Elab.sgn', + bind : 'context * binder -> 'context} + -> 'context -> Elab.sgn -> Elab.sgn + +end + +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 mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB, + sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB, + sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB, + str : ('context, Elab.str', 'state, 'abort) Search.mapfolderB, + decl : ('context, Elab.decl', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Elab.decl, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder, + con : (Elab.con', 'state, 'abort) Search.mapfolder, + exp : (Elab.exp', 'state, 'abort) Search.mapfolder, + sgn_item : (Elab.sgn_item', 'state, 'abort) Search.mapfolder, + sgn : (Elab.sgn', 'state, 'abort) Search.mapfolder, + str : (Elab.str', 'state, 'abort) Search.mapfolder, + decl : (Elab.decl', 'state, 'abort) Search.mapfolder} + -> (Elab.decl, 'state, 'abort) Search.mapfolder + val exists : {kind : Elab.kind' -> bool, + con : Elab.con' -> bool, + exp : Elab.exp' -> bool, + sgn_item : Elab.sgn_item' -> bool, + sgn : Elab.sgn' -> bool, + str : Elab.str' -> bool, + decl : Elab.decl' -> bool} + -> Elab.decl -> bool + val search : {kind : Elab.kind' -> 'a option, + con : Elab.con' -> 'a option, + exp : Elab.exp' -> 'a option, + sgn_item : Elab.sgn_item' -> 'a option, + sgn : Elab.sgn' -> 'a option, + str : Elab.str' -> 'a option, + decl : Elab.decl' -> 'a option} + -> Elab.decl -> 'a option + + val foldMapB : {kind : 'context * Elab.kind' * 'state -> Elab.kind' * 'state, + con : 'context * Elab.con' * 'state -> Elab.con' * 'state, + exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state, + sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state, + sgn : 'context * Elab.sgn' * 'state -> Elab.sgn' * 'state, + str : 'context * Elab.str' * 'state -> Elab.str' * 'state, + decl : 'context * Elab.decl' * 'state -> Elab.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.decl -> Elab.decl * 'state + + val map : {kind : Elab.kind' -> Elab.kind', + con : Elab.con' -> Elab.con', + exp : Elab.exp' -> Elab.exp', + sgn_item : Elab.sgn_item' -> Elab.sgn_item', + sgn : Elab.sgn' -> Elab.sgn', + str : Elab.str' -> Elab.str', + decl : Elab.decl' -> Elab.decl'} + -> Elab.decl -> Elab.decl + + val mapB : {kind : 'context -> Elab.kind' -> Elab.kind', + con : 'context -> Elab.con' -> Elab.con', + exp : 'context -> Elab.exp' -> Elab.exp', + sgn_item : 'context -> Elab.sgn_item' -> Elab.sgn_item', + sgn : 'context -> Elab.sgn' -> Elab.sgn', + str : 'context -> Elab.str' -> Elab.str', + decl : 'context -> Elab.decl' -> Elab.decl', + bind : 'context * binder -> 'context} + -> 'context -> Elab.decl -> Elab.decl + + 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 +end + +structure File : sig + val maxName : Elab.file -> int + + val findDecl : (Elab.decl -> bool) -> Elab.file -> Elab.decl option +end + +end diff --git a/src/elab_util.sml b/src/elab_util.sml new file mode 100644 index 0000000..0cdb9cc --- /dev/null +++ b/src/elab_util.sml @@ -0,0 +1,1310 @@ +(* 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 ElabUtil :> ELAB_UTIL = struct + +open Elab + +fun classifyDatatype xncs = + case xncs of + [(_, _, NONE), (_, _, SOME _)] => Option + | [(_, _, SOME _), (_, _, NONE)] => Option + | _ => + if List.all (fn (_, _, NONE) => true | _ => false) xncs then + Enum + else + Default + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindP (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 + +fun mapfold fk = + mapfoldB {kind = fn () => fk, + bind = fn ((), _) => ()} () + +fun mapB {kind, bind} ctx k = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + bind = bind} ctx k () of + S.Continue (k, ()) => k + | S.Return _ => raise Fail "ElabUtil.Kind.mapB: Impossible" + +fun exists f k = + case mapfold (fn k => fn () => + if f k then + S.Return () + else + S.Continue (k, ())) k () of + S.Return _ => true + | S.Continue _ => false + +fun foldB {kind, bind} ctx st k = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)), + bind = bind} ctx k st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Kind.foldB: Impossible" + +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.bindP (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 + +fun mapfold {kind = fk, con = fc} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + bind = fn ((), _) => ()} () + +fun mapB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + bind = bind} ctx c () of + S.Continue (c, ()) => c + | S.Return _ => raise Fail "ElabUtil.Con.mapB: Impossible" + +fun map {kind, con} s = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ())} s () of + S.Return () => raise Fail "ElabUtil.Con.map: Impossible" + | S.Continue (s, ()) => s + +fun appB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => (kind ctx k; S.Continue (k, ())), + con = fn ctx => fn c => fn () => (con ctx c; S.Continue (c, ())), + bind = bind} ctx c () of + S.Continue _ => () + | S.Return _ => raise Fail "ElabUtil.Con.appB: Impossible" + +fun app {kind, con} s = + case mapfold {kind = fn k => fn () => (kind k; S.Continue (k, ())), + con = fn c => fn () => (con c; S.Continue (c, ()))} s () of + S.Return () => raise Fail "ElabUtil.Con.app: Impossible" + | S.Continue _ => () + +fun existsB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + bind = bind} ctx c () of + S.Return _ => true + | S.Continue _ => false + +fun exists {kind, con} c = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ())} c () of + S.Return _ => true + | S.Continue _ => false + +fun foldB {kind, con, bind} ctx st c = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + bind = bind} ctx c st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Con.foldB: Impossible" + +fun fold {kind, con} st c = + case mapfoldB {kind = fn () => fn k => fn st => S.Continue (k, kind (k, st)), + con = fn () => fn c => fn st => S.Continue (c, con (c, st)), + bind = fn ((), _) => ()} () c st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Con.fold: Impossible" + +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.bindP (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 + +fun mapfold {kind = fk, con = fc, exp = fe} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + exp = fn () => fe, + bind = fn ((), _) => ()} () + +fun existsB {kind, con, exp, bind} ctx e = + case mapfoldB {kind = fn ctx => fn k => fn () => + if kind (ctx, k) then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx e () of + S.Return _ => true + | S.Continue _ => false + +fun exists {kind, con, exp} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ())} k () of + S.Return _ => true + | S.Continue _ => false + +fun mapB {kind, con, exp, bind} ctx e = + 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, ()), + bind = bind} ctx e () of + S.Continue (e, ()) => e + | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible" + +fun foldB {kind, con, exp, bind} ctx st e = + case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)), + bind = bind} ctx e st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Exp.foldB: Impossible" + +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.bindP (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.bindP (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 + +fun mapfold {kind, con, sgn_item, sgn} = + mapfoldB {kind = fn () => kind, + con = fn () => con, + sgn_item = fn () => sgn_item, + sgn = fn () => sgn, + bind = fn ((), _) => ()} () + +fun mapB {kind, con, sgn_item, sgn, bind} ctx s = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + sgn_item = fn ctx => fn sgi => fn () => S.Continue (sgn_item ctx sgi, ()), + sgn = fn ctx => fn s => fn () => S.Continue (sgn ctx s, ()), + bind = bind} ctx s () of + S.Continue (s, ()) => s + | S.Return _ => raise Fail "ElabUtil.Sgn.mapB: Impossible" + +fun map {kind, con, sgn_item, sgn} s = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ()), + sgn_item = fn si => fn () => S.Continue (sgn_item si, ()), + sgn = fn s => fn () => S.Continue (sgn s, ())} s () of + S.Return () => raise Fail "Elab_util.Sgn.map" + | S.Continue (s, ()) => s + +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.bindP (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.bindP (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 mapfold {kind, con, exp, sgn_item, sgn, str, decl} = + mapfoldB {kind = fn () => kind, + con = fn () => con, + exp = fn () => exp, + sgn_item = fn () => sgn_item, + sgn = fn () => sgn, + str = fn () => str, + decl = fn () => decl, + bind = fn ((), _) => ()} () + +fun exists {kind, con, exp, sgn_item, sgn, str, decl} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ()), + sgn_item = fn sgi => fn () => + if sgn_item sgi then + S.Return () + else + S.Continue (sgi, ()), + sgn = fn x => fn () => + if sgn x then + S.Return () + else + S.Continue (x, ()), + str = fn x => fn () => + if str x then + S.Return () + else + S.Continue (x, ()), + decl = fn x => fn () => + if decl x then + S.Return () + else + S.Continue (x, ())} k () of + S.Return _ => true + | S.Continue _ => false + +fun search {kind, con, exp, sgn_item, sgn, str, decl} k = + case mapfold {kind = fn x => fn () => + case kind x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + con = fn x => fn () => + case con x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + exp = fn x => fn () => + case exp x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + sgn_item = fn x => fn () => + case sgn_item x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + sgn = fn x => fn () => + case sgn x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + str = fn x => fn () => + case str x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v, + + decl = fn x => fn () => + case decl x of + NONE => S.Continue (x, ()) + | SOME v => S.Return v + + } k () of + S.Return x => SOME x + | S.Continue _ => NONE + +fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d = + case mapfoldB {kind = fn ctx => fn x => fn st => S.Continue (kind (ctx, x, st)), + con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)), + exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)), + sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)), + sgn = fn ctx => fn x => fn st => S.Continue (sgn (ctx, x, st)), + str = fn ctx => fn x => fn st => S.Continue (str (ctx, x, st)), + decl = fn ctx => fn x => fn st => S.Continue (decl (ctx, x, st)), + bind = bind} ctx d st of + S.Continue x => x + | S.Return _ => raise Fail "ElabUtil.Decl.foldMapB: Impossible" + +fun map {kind, con, exp, sgn_item, sgn, str, decl} s = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + sgn_item = fn si => fn () => S.Continue (sgn_item si, ()), + sgn = fn s => fn () => S.Continue (sgn s, ()), + str = fn si => fn () => S.Continue (str si, ()), + decl = fn s => fn () => S.Continue (decl s, ())} s () of + S.Return () => raise Fail "Elab_util.Decl.map" + | S.Continue (s, ()) => s + +fun mapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx s = + 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 c => fn () => S.Continue (exp ctx c, ()), + sgn_item = fn ctx => fn sgi => fn () => S.Continue (sgn_item ctx sgi, ()), + sgn = fn ctx => fn s => fn () => S.Continue (sgn ctx s, ()), + str = fn ctx => fn sgi => fn () => S.Continue (str ctx sgi, ()), + decl = fn ctx => fn s => fn () => S.Continue (decl ctx s, ()), + bind = bind} ctx s () of + S.Continue (s, ()) => s + | S.Return _ => raise Fail "ElabUtil.Decl.mapB: Impossible" + +fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a = + case mapfold {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn c => fn st => S.Continue (c, con (c, st)), + exp = fn e => fn st => S.Continue (e, exp (e, st)), + sgn_item = fn sgi => fn st => S.Continue (sgi, sgn_item (sgi, st)), + sgn = fn s => fn st => S.Continue (s, sgn (s, st)), + str = fn str' => fn st => S.Continue (str', str (str', st)), + decl = fn d => fn st => S.Continue (d, decl (d, st))} d st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible" + +end + +structure File = struct + +fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds + +and maxNameDecl (d, _) = + case d of + DCon (_, n, _, _) => n + | DDatatype dts => + foldl (fn ((_, n, _, ns), max) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, max)) ns) 0 dts + | DDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | DVal (_, n, _, _) => n + | DValRec vis => foldl (fn ((_, n, _, _), count) => Int.max (n, count)) 0 vis + | DStr (_, n, sgn, str) => Int.max (n, Int.max (maxNameSgn sgn, maxNameStr str)) + | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DConstraint _ => 0 + | DExport _ => 0 + | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) + | DSequence (n1, _, n2) => Int.max (n1, n2) + | DView (n1, _, n2, _, _) => Int.max (n1, n2) + | DDatabase _ => 0 + | DCookie (n1, _, n2, _) => Int.max (n1, n2) + | DStyle (n1, _, n2) => Int.max (n1, n2) + | DTask _ => 0 + | DPolicy _ => 0 + | DOnError _ => 0 + | DFfi (_, n, _, _) => n +and maxNameStr (str, _) = + case str of + StrConst ds => maxName ds + | StrVar n => n + | StrProj (str, _) => maxNameStr str + | StrFun (_, n, dom, ran, str) => foldl Int.max n [maxNameSgn dom, maxNameSgn ran, maxNameStr str] + | StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2) + | StrError => 0 + +and maxNameSgn (sgn, _) = + case sgn of + SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis + | SgnVar n => n + | SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran)) + | SgnWhere (sgn, _, _, _) => maxNameSgn sgn + | SgnProj (n, _, _) => n + | SgnError => 0 + +and maxNameSgi (sgi, _) = + case sgi of + SgiConAbs (_, n, _) => n + | SgiCon (_, n, _, _) => n + | SgiDatatype dts => + foldl (fn ((_, n, _, ns), max) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, max)) ns) 0 dts + | SgiDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | SgiVal (_, n, _) => n + | SgiStr (_, _, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiConstraint _ => 0 + | SgiClassAbs (_, n, _) => n + | SgiClass (_, n, _, _) => n + +fun findDecl pred file = + let + fun decl d = + let + val r = case #1 d of + DStr (_, _, _, s) => str s + | _ => NONE + in + case r of + NONE => if pred d then SOME d else NONE + | _ => r + end + + and str s = + case #1 s of + StrConst ds => ListUtil.search decl ds + | StrFun (_, _, _, _, s) => str s + | StrApp (s1, s2) => + (case str s1 of + NONE => str s2 + | r => r) + | _ => NONE + in + ListUtil.search decl file + end + +end + +end diff --git a/src/elaborate.sig b/src/elaborate.sig new file mode 100644 index 0000000..d60cff4 --- /dev/null +++ b/src/elaborate.sig @@ -0,0 +1,50 @@ +(* Copyright (c) 2008, 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 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 + + val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option + + val dumpTypes : bool ref + (* After elaboration (successful or failed), should I output a mapping from + * all identifiers to their kinds/types? *) + + val dumpTypesOnError : bool ref + (* Like above, but only used if there are compile errors. *) + + val unifyMore : bool ref + (* Run all phases of type inference, even if an error is detected by an + * early phase. *) + + val incremental : bool ref + val verbose : bool ref + +end diff --git a/src/elaborate.sml b/src/elaborate.sml new file mode 100644 index 0000000..4a04d4b --- /dev/null +++ b/src/elaborate.sml @@ -0,0 +1,5100 @@ +(* Copyright (c) 2008-2014, 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 Elaborate :> ELABORATE = struct + + structure P = Prim + structure L = Source + structure L' = Elab + structure E = ElabEnv + structure U = ElabUtil + structure D = Disjoint + + open Print + open ElabPrint + open ElabErr + + val dumpTypes = ref false + val dumpTypesOnError = ref false + val unifyMore = ref false + val incremental = ref false + val verbose = ref false + + structure IS = IntBinarySet + structure IM = IntBinaryMap + + structure SK = struct + type ord_key = string + val compare = String.compare + end + + structure SS = BinarySetFn(SK) + structure SM = BinaryMapFn(SK) + + val basis_r = ref 0 + val top_r = ref 0 + + fun elabExplicitness e = + case e of + L.Explicit => L'.Explicit + | L.Implicit => L'.Implicit + + fun occursKind r = + U.Kind.exists (fn L'.KUnif (_, _, r') => r = r' + | _ => false) + + fun validateCon env c = + (U.Con.appB {kind = fn env' => fn k => case k of + L'.KRel n => ignore (E.lookupKRel env' n) + | L'.KUnif (_, _, r as ref (L'.KUnknown f)) => + r := L'.KUnknown (fn k => f k andalso validateKind env' k) + | _ => (), + con = fn env' => fn c => case c of + L'.CRel n => ignore (E.lookupCRel env' n) + | L'.CNamed n => ignore (E.lookupCNamed env' n) + | L'.CModProj (n, _, _) => ignore (E.lookupStrNamed env' n) + | L'.CUnif (_, _, _, _, r as ref (L'.Unknown f)) => + r := L'.Unknown (fn c => f c andalso validateCon env' c) + | _ => (), + bind = fn (env', b) => case b of + U.Con.RelK x => E.pushKRel env' x + | U.Con.RelC (x, k) => E.pushCRel env' x k + | U.Con.NamedC (x, n, k, co) => E.pushCNamedAs env x n k co} + env c; + true) + handle _ => false + + and validateKind env k = validateCon env (L'.CRecord (k, []), ErrorMsg.dummySpan) + + exception KUnify' of E.env * kunify_error + + fun unifyKinds' env (k1All as (k1, _)) (k2All as (k2, _)) = + let + fun err f = raise KUnify' (env, f (k1All, k2All)) + in + case (k1, k2) of + (L'.KType, L'.KType) => () + | (L'.KUnit, L'.KUnit) => () + + | (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) => + (unifyKinds' env d1 d2; + unifyKinds' env r1 r2) + | (L'.KName, L'.KName) => () + | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' env k1 k2 + | (L'.KTuple ks1, L'.KTuple ks2) => + ((ListPair.appEq (fn (k1, k2) => unifyKinds' env k1 k2) (ks1, ks2)) + handle ListPair.UnequalLengths => err KIncompatible) + + | (L'.KRel n1, L'.KRel n2) => + if n1 = n2 then + () + else + err KIncompatible + | (L'.KFun (x, k1), L'.KFun (_, k2)) => + unifyKinds' (E.pushKRel env x) k1 k2 + + | (L'.KError, _) => () + | (_, L'.KError) => () + + | (L'.KUnif (_, _, ref (L'.KKnown k1All)), _) => unifyKinds' env k1All k2All + | (_, L'.KUnif (_, _, ref (L'.KKnown k2All))) => unifyKinds' env k1All k2All + + | (L'.KTupleUnif (_, _, ref (L'.KKnown k)), _) => unifyKinds' env k k2All + | (_, L'.KTupleUnif (_, _, ref (L'.KKnown k))) => unifyKinds' env k1All k + + | (L'.KUnif (_, _, r1 as ref (L'.KUnknown f1)), L'.KUnif (_, _, r2 as ref (L'.KUnknown f2))) => + if r1 = r2 then + () + else + (r1 := L'.KKnown k2All; + r2 := L'.KUnknown (fn x => f1 x andalso f2 x)) + + | (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) => + if occursKind r k2All then + err KOccursCheckFailed + else if not (f k2All) then + err KScope + else + r := L'.KKnown k2All + | (_, L'.KUnif (_, _, r as ref (L'.KUnknown f))) => + if occursKind r k1All then + err KOccursCheckFailed + else if not (f k1All) then + err KScope + else + r := L'.KKnown k1All + + | (L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f)), L'.KTuple ks) => + if not (f k2All) then + err KScope + else + ((app (fn (n, k) => unifyKinds' env k (List.nth (ks, n-1))) nks; + r := L'.KKnown k2All) + handle Subscript => err KIncompatible) + | (L'.KTuple ks, L'.KTupleUnif (_, nks, r as ref (L'.KUnknown f))) => + if not (f k2All) then + err KScope + else + ((app (fn (n, k) => unifyKinds' env (List.nth (ks, n-1)) k) nks; + r := L'.KKnown k1All) + handle Subscript => err KIncompatible) + | (L'.KTupleUnif (loc, nks1, r1 as ref (L'.KUnknown f1)), L'.KTupleUnif (_, nks2, r2 as ref (L'.KUnknown f2))) => + if r1 = r2 then + () + else + let + val nks = foldl (fn (p as (n, k1), nks) => + case ListUtil.search (fn (n', k2) => + if n' = n then + SOME k2 + else + NONE) nks2 of + NONE => p :: nks + | SOME k2 => (unifyKinds' env k1 k2; + nks)) nks2 nks1 + + val k = (L'.KTupleUnif (loc, nks, ref (L'.KUnknown (fn x => f1 x andalso f2 x))), loc) + in + r1 := L'.KKnown k; + r2 := L'.KKnown k + end + + | _ => err KIncompatible + end + + exception KUnify of L'.kind * L'.kind * E.env * kunify_error + + fun unifyKinds env k1 k2 = + unifyKinds' env k1 k2 + handle KUnify' (env', err) => raise KUnify (k1, k2, env', err) + + fun checkKind env c k1 k2 = + unifyKinds env k1 k2 + handle KUnify (k1, k2, env', err) => + conError env (WrongKind (c, k1, k2, env', err)) + + val dummy = ErrorMsg.dummySpan + + val ktype = (L'.KType, dummy) + val kname = (L'.KName, dummy) + val ktype_record = (L'.KRecord ktype, dummy) + + val cerror = (L'.CError, dummy) + val kerror = (L'.KError, dummy) + val eerror = (L'.EError, dummy) + val sgnerror = (L'.SgnError, dummy) + val strerror = (L'.StrError, dummy) + + val int = ref cerror + val float = ref cerror + val string = ref cerror + val char = ref cerror + val table = ref cerror + + + local + val count = ref 0 + in + + fun resetKunif () = count := 0 + + fun kunif' f loc = + let + val n = !count + val s = if n <= 26 then + str (chr (ord #"A" + n)) + else + "U" ^ Int.toString (n - 26) + in + count := n + 1; + (L'.KUnif (loc, s, ref (L'.KUnknown f)), loc) + end + + fun kunif env = kunif' (validateKind env) + + end + + local + val count = ref 0 + in + + fun resetCunif () = count := 0 + + fun cunif' f (loc, k) = + let + val n = !count + val s = if n < 26 then + str (chr (ord #"A" + n)) + else + "U" ^ Int.toString (n - 26) + in + count := n + 1; + (L'.CUnif (0, loc, k, s, ref (L'.Unknown f)), loc) + end + + fun cunif env = cunif' (validateCon env) + + end + + fun elabKind env (k, loc) = + case k of + L.KType => (L'.KType, loc) + | L.KArrow (k1, k2) => (L'.KArrow (elabKind env k1, elabKind env k2), loc) + | L.KName => (L'.KName, loc) + | 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.KVar s => (case E.lookupK env s of + NONE => + (kindError env (UnboundKind (loc, s)); + kerror) + | SOME n => (L'.KRel n, loc)) + | L.KFun (x, k) => (L'.KFun (x, elabKind (E.pushKRel env x) k), loc) + + fun mapKind (dom, ran, loc)= + (L'.KArrow ((L'.KArrow (dom, ran), loc), + (L'.KArrow ((L'.KRecord dom, loc), + (L'.KRecord ran, loc)), loc)), loc) + + fun hnormKind (kAll as (k, _)) = + case k of + L'.KUnif (_, _, ref (L'.KKnown k)) => hnormKind k + | L'.KTupleUnif (_, _, ref (L'.KKnown k)) => hnormKind k + | _ => kAll + + open ElabOps + + fun elabConHead env (c as (_, loc)) k = + let + fun unravel (k, c) = + case hnormKind k of + (L'.KFun (x, k'), _) => + let + val u = kunif env loc + + val k'' = subKindInKind (0, u) k' + in + unravel (k'', (L'.CKApp (c, u), loc)) + end + | _ => (c, k) + in + unravel (k, c) + end + + fun elabCon (env, denv) (c, loc) = + case c of + L.CAnnot (c, k) => + let + val k' = elabKind env k + val (c', ck, gs) = elabCon (env, denv) c + in + checkKind env c' ck k'; + (c', k', gs) + end + + | L.TFun (t1, t2) => + let + val (t1', k1, gs1) = elabCon (env, denv) t1 + val (t2', k2, gs2) = elabCon (env, denv) t2 + in + checkKind env t1' k1 ktype; + checkKind env t2' k2 ktype; + ((L'.TFun (t1', t2'), loc), ktype, gs1 @ gs2) + end + | L.TCFun (e, x, k, t) => + let + val e' = elabExplicitness e + val k' = elabKind env k + val env' = E.pushCRel env x k' + val (t', tk, gs) = elabCon (env', D.enter denv) t + in + checkKind env t' tk ktype; + ((L'.TCFun (e', x, k', t'), loc), ktype, gs) + end + | L.TKFun (x, t) => + let + val env' = E.pushKRel env x + val (t', tk, gs) = elabCon (env', denv) t + in + checkKind env t' tk ktype; + ((L'.TKFun (x, t'), loc), ktype, gs) + end + | L.TDisjoint (c1, c2, c) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + + val ku1 = kunif env loc + val ku2 = kunif env loc + + val denv' = D.assert env denv (c1', c2') + val (c', k, gs4) = elabCon (env, denv') c + in + checkKind env c1' k1 (L'.KRecord ku1, loc); + checkKind env c2' k2 (L'.KRecord ku2, loc); + checkKind env c' k (L'.KType, loc); + + ((L'.TDisjoint (c1', c2', c'), loc), k, gs1 @ gs2 @ gs4) + end + | L.TRecord c => + let + val (c', ck, gs) = elabCon (env, denv) c + val k = (L'.KRecord ktype, loc) + in + checkKind env c' ck k; + ((L'.TRecord c', loc), ktype, gs) + end + + | L.CVar ([], s) => + (case E.lookupC env s of + E.NotBound => + (conError env (UnboundCon (loc, s)); + (cerror, kerror, [])) + | E.Rel (n, k) => + let + val (c, k) = elabConHead env (L'.CRel n, loc) k + in + (c, k, []) + end + | E.Named (n, k) => + let + val (c, k) = elabConHead env (L'.CNamed n, loc) k + in + (c, k, []) + end) + | L.CVar (m1 :: ms, s) => + (case E.lookupStr env m1 of + NONE => (conError env (UnboundStrInCon (loc, m1)); + (cerror, kerror, [])) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val (c, k) = case E.projectCon env {sgn = sgn, str = str, field = s} of + NONE => (conError env (UnboundCon (loc, s)); + (cerror, kerror)) + | SOME (k, _) => elabConHead env (L'.CModProj (n, ms, s), loc) k + in + (c, k, []) + end) + + | L.CApp (c1, c2) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + val dom = kunif env loc + val ran = kunif env loc + in + checkKind env c1' k1 (L'.KArrow (dom, ran), loc); + checkKind env c2' k2 dom; + ((L'.CApp (c1', c2'), loc), ran, gs1 @ gs2) + end + | L.CAbs (x, ko, t) => + let + val k' = case ko of + NONE => kunif env loc + | SOME k => elabKind env k + val env' = E.pushCRel env x k' + val (t', tk, gs) = elabCon (env', D.enter denv) t + in + ((L'.CAbs (x, k', t'), loc), + (L'.KArrow (k', tk), loc), + gs) + end + | L.CKAbs (x, t) => + let + val env' = E.pushKRel env x + val (t', tk, gs) = elabCon (env', denv) t + in + ((L'.CKAbs (x, t'), loc), + (L'.KFun (x, tk), loc), + gs) + end + + | L.CName s => + ((L'.CName s, loc), kname, []) + + | L.CRecord xcs => + let + val k = kunif env loc + + val (xcs', gs) = ListUtil.foldlMap (fn ((x, c), gs) => + let + val (x', xk, gs1) = elabCon (env, denv) x + val (c', ck, gs2) = elabCon (env, denv) c + in + checkKind env x' xk kname; + checkKind env c' ck k; + ((x', c'), gs1 @ gs2 @ gs) + end) [] xcs + + val rc = (L'.CRecord (k, xcs'), loc) + (* Add duplicate field checking later. *) + + fun prove (xcs, ds) = + case xcs of + [] => ds + | xc :: rest => + let + val r1 = (L'.CRecord (k, [xc]), loc) + val ds = foldl (fn (xc', ds) => + let + val r2 = (L'.CRecord (k, [xc']), loc) + in + D.prove env denv (r1, r2, loc) @ ds + end) + ds rest + in + prove (rest, ds) + end + in + (rc, (L'.KRecord k, loc), prove (xcs', gs)) + end + | L.CConcat (c1, c2) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + val ku = kunif env loc + val k = (L'.KRecord ku, loc) + in + checkKind env c1' k1 k; + checkKind env c2' k2 k; + ((L'.CConcat (c1', c2'), loc), k, + D.prove env denv (c1', c2', loc) @ gs1 @ gs2) + end + | L.CMap => + let + val dom = kunif env loc + val ran = kunif env loc + in + ((L'.CMap (dom, ran), loc), + mapKind (dom, ran, loc), + []) + end + + | L.CUnit => ((L'.CUnit, loc), (L'.KUnit, loc), []) + + | L.CTuple cs => + let + val (cs', ks, gs) = foldl (fn (c, (cs', ks, gs)) => + let + val (c', k, gs') = elabCon (env, denv) c + in + (c' :: cs', k :: ks, gs' @ gs) + end) ([], [], []) cs + in + ((L'.CTuple (rev cs'), loc), (L'.KTuple (rev ks), loc), gs) + end + | L.CProj (c, n) => + let + val (c', k, gs) = elabCon (env, denv) c + + val k' = kunif env loc + in + if n <= 0 then + (conError env (ProjBounds (c', n)); + (cerror, kerror, [])) + else + (checkKind env c' k (L'.KTupleUnif (loc, [(n, k')], ref (L'.KUnknown (validateKind env))), loc); + ((L'.CProj (c', n), loc), k', gs)) + end + + | L.CWild k => + let + val k' = elabKind env k + in + (cunif env (loc, k'), k', []) + end + + fun kunifsRemain k = + case k of + L'.KUnif (_, _, ref (L'.KUnknown _)) => true + | L'.KTupleUnif (_, _, ref (L'.KUnknown _)) => true + | _ => false + fun cunifsRemain c = + case c of + L'.CUnif (_, loc, k, _, r as ref (L'.Unknown _)) => + (case #1 (hnormKind k) of + L'.KUnit => (r := L'.Known (L'.CUnit, loc); false) + | _ => true) + | _ => false + + val kunifsInDecl = U.Decl.exists {kind = kunifsRemain, + con = fn _ => false, + exp = fn _ => false, + sgn_item = fn _ => false, + sgn = fn _ => false, + str = fn _ => false, + decl = fn _ => false} + + val cunifsInDecl = U.Decl.exists {kind = fn _ => false, + con = cunifsRemain, + exp = fn _ => false, + sgn_item = fn _ => false, + sgn = fn _ => false, + str = fn _ => false, + decl = fn _ => false} + + fun occursCon r = + U.Con.exists {kind = fn _ => false, + con = fn L'.CUnif (_, _, _, _, r') => r = r' + | _ => false} + + exception CUnify' of E.env * cunify_error + + type record_summary = { + fields : (L'.con * L'.con) list, + unifs : (L'.con * L'.cunif ref) list, + others : L'.con list + } + + fun summaryToCon {fields, unifs, others} = + let + fun concat (c1, c2) = + case #1 c1 of + L'.CRecord (_, []) => c2 + | _ => case #1 c2 of + L'.CRecord (_, []) => c1 + | _ => (L'.CConcat (c1, c2), dummy) + + val c = (L'.CRecord (ktype, []), dummy) + val c = List.foldr concat c others + val c = List.foldr (fn ((c', _), c) => concat (c', c)) c unifs + in + concat ((L'.CRecord (ktype, fields), dummy), c) + end + + fun p_summary env s = p_con env (summaryToCon s) + + exception CUnify of L'.con * L'.con * E.env * cunify_error + + fun kindof env (c, loc) = + case c of + L'.TFun _ => ktype + | L'.TCFun _ => ktype + | L'.TRecord _ => ktype + | L'.TDisjoint _ => ktype + + | L'.CRel xn => #2 (E.lookupCRel env xn) + | L'.CNamed xn => #2 (E.lookupCNamed env xn) + | L'.CModProj (n, ms, x) => + let + val (_, sgn) = E.lookupStrNamed env n + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "kindof: Unknown substructure" + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectCon env {sgn = sgn, str = str, field = x} of + NONE => raise Fail "kindof: Unknown con in structure" + | SOME (k, _) => k + end + + | L'.CApp (c, _) => + (case hnormKind (kindof env c) of + (L'.KArrow (_, k), _) => k + | (L'.KError, _) => kerror + | k => raise CUnify' (env, CKindof (k, c, "arrow"))) + | L'.CAbs (x, k, c) => (L'.KArrow (k, kindof (E.pushCRel env x k) c), loc) + + + | L'.CName _ => kname + + | L'.CRecord (k, _) => (L'.KRecord k, loc) + | L'.CConcat (c, _) => kindof env c + | L'.CMap (dom, ran) => mapKind (dom, ran, loc) + + | L'.CUnit => (L'.KUnit, loc) + + | L'.CTuple cs => (L'.KTuple (map (kindof env) cs), loc) + | L'.CProj (c, n) => + (case hnormKind (kindof env c) of + (L'.KTuple ks, _) => List.nth (ks, n - 1) + | (L'.KUnif (_, _, r), _) => + let + val ku = kunif env loc + val k = (L'.KTupleUnif (loc, [(n, ku)], ref (L'.KUnknown (fn _ => true))), loc) + in + r := L'.KKnown k; + ku + end + | (L'.KTupleUnif (_, nks, r), _) => + (case ListUtil.search (fn (n', k) => if n' = n then SOME k else NONE) nks of + SOME k => k + | NONE => + let + val ku = kunif env loc + val k = (L'.KTupleUnif (loc, ((n, ku) :: nks), ref (L'.KUnknown (fn _ => true))), loc) + in + r := L'.KKnown k; + ku + end) + | k => raise CUnify' (env, CKindof (k, c, "tuple"))) + + | L'.CError => kerror + | L'.CUnif (_, _, k, _, _) => k + + | L'.CKAbs (x, c) => (L'.KFun (x, kindof (E.pushKRel env x) c), loc) + | L'.CKApp (c, k) => + (case hnormKind (kindof env c) of + (L'.KFun (_, k'), _) => subKindInKind (0, k) k' + | k => raise CUnify' (env, CKindof (k, c, "kapp"))) + | L'.TKFun _ => ktype + + exception GuessFailure + + fun isUnitCon env (c, loc) = + case c of + L'.TFun _ => false + | L'.TCFun _ => false + | L'.TRecord _ => false + | L'.TDisjoint _ => false + + | L'.CRel xn => #1 (hnormKind (#2 (E.lookupCRel env xn))) = L'.KUnit + | L'.CNamed xn => #1 (hnormKind (#2 (E.lookupCNamed env xn))) = L'.KUnit + | L'.CModProj (n, ms, x) => false + (*let + val (_, sgn) = E.lookupStrNamed env n + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "kindof: Unknown substructure" + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectCon env {sgn = sgn, str = str, field = x} of + NONE => raise Fail "kindof: Unknown con in structure" + | SOME ((k, _), _) => k = L'.KUnit + end*) + + | L'.CApp (c, _) => false + (*(case hnormKind (kindof env c) of + (L'.KArrow (_, k), _) => #1 k = L'.KUnit + | (L'.KError, _) => false + | k => raise CUnify' (CKindof (k, c, "arrow")))*) + | L'.CAbs _ => false + + | L'.CName _ => false + + | L'.CRecord _ => false + | L'.CConcat _ => false + | L'.CMap _ => false + + | L'.CUnit => true + + | L'.CTuple _ => false + | L'.CProj (c, n) => false + (*(case hnormKind (kindof env c) of + (L'.KTuple ks, _) => #1 (List.nth (ks, n - 1)) = L'.KUnit + | k => raise CUnify' (CKindof (k, c, "tuple")))*) + + | L'.CError => false + | L'.CUnif (_, _, k, _, _) => #1 (hnormKind k) = L'.KUnit + + | L'.CKAbs _ => false + | L'.CKApp _ => false + | L'.TKFun _ => false + + val recdCounter = ref 0 + + val mayDelay = ref false + val delayedUnifs = ref ([] : (ErrorMsg.span * E.env * L'.kind * record_summary * record_summary) list) + + val delayedExhaustives = ref ([] : (E.env * L'.con * L'.pat list * ErrorMsg.span) list) + + exception CantSquish + + fun squish by = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + L'.CRel xn => + if xn < bound then + c + else if bound <= xn andalso xn < bound + by then + raise CantSquish + else + L'.CRel (xn - by) + | L'.CUnif _ => raise CantSquish + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} 0 + + val reducedSummaries = ref (NONE : (Print.PD.pp_desc * Print.PD.pp_desc) option) + + fun unifyRecordCons env (loc, c1, c2) = + let + fun rkindof c = + case hnormKind (kindof env c) of + (L'.KRecord k, _) => k + | (L'.KError, _) => kerror + | (L'.KUnif (_, _, r as ref (L'.KUnknown f)), _) => + let + val k = kunif' f (#2 c) + in + r := L'.KKnown (L'.KRecord k, #2 c); + k + end + | k => raise CUnify' (env, CKindof (k, c, "record")) + + val k1 = rkindof c1 + val k2 = rkindof c2 + + val r1 = recordSummary env c1 + val r2 = recordSummary env c2 + in + unifyKinds env k1 k2; + unifySummaries env (loc, k1, r1, r2) + end + + and normalizeRecordSummary env (r : record_summary) = + recordSummary env (summaryToCon r) + + and recordSummary env c = + let + val c = hnormCon env c + + val sum = + case c of + (L'.CRecord (_, xcs), _) => {fields = map (fn (x, c) => (hnormCon env x, hnormCon env c)) xcs, + unifs = [], others = []} + | (L'.CConcat (c1, c2), _) => + let + val s1 = recordSummary env c1 + val s2 = recordSummary env c2 + in + {fields = #fields s1 @ #fields s2, + unifs = #unifs s1 @ #unifs s2, + others = #others s1 @ #others s2} + end + | (L'.CUnif (nl, _, _, _, ref (L'.Known c)), _) => recordSummary env (E.mliftConInCon nl c) + | c' as (L'.CUnif (0, _, _, _, r), _) => {fields = [], unifs = [(c', r)], others = []} + | c' => {fields = [], unifs = [], others = [c']} + in + sum + end + + and consEq env loc (c1, c2) = + let + val mayDelay' = !mayDelay + in + (mayDelay := false; + unifyCons env loc c1 c2; + mayDelay := mayDelay'; + true) + handle CUnify _ => (mayDelay := mayDelay'; false) + end + + and consNeq env (c1, c2) = + case (#1 (hnormCon env c1), #1 (hnormCon env c2)) of + (L'.CName x1, L'.CName x2) => x1 <> x2 + | (L'.CName _, L'.CRel _) => true + | (L'.CRel _, L'.CName _) => true + | (L'.CRel n1, L'.CRel n2) => n1 <> n2 + | (L'.CRel _, L'.CNamed _) => true + | (L'.CNamed _, L'.CRel _) => true + | (L'.CRel _, L'.CModProj _) => true + | (L'.CModProj _, L'.CRel _) => true + | (L'.CModProj (_, _, n1), L'.CModProj (_, _, n2)) => n1 <> n2 + | (L'.CModProj _, L'.CName _) => true + | (L'.CName _, L'.CModProj _) => true + | (L'.CNamed _, L'.CName _) => true + | (L'.CName _, L'.CNamed _) => true + | _ => false + + and unifySummaries env (loc, k, s1 : record_summary, s2 : record_summary) = + let + val () = reducedSummaries := NONE + + (*val () = eprefaces "Summaries" [("loc", PD.string (ErrorMsg.spanToString loc)), + ("#1", p_summary env s1), + ("#2", p_summary env s2)]*) + + fun eatMatching p (ls1, ls2) = + let + fun em (ls1, ls2, passed1) = + case ls1 of + [] => (rev passed1, ls2) + | h1 :: t1 => + let + fun search (ls2', passed2) = + case ls2' of + [] => em (t1, ls2, h1 :: passed1) + | h2 :: t2 => + if p (h1, h2) then + em (t1, List.revAppend (passed2, t2), passed1) + else + search (t2, h2 :: passed2) + in + search (ls2, []) + end + in + em (ls1, ls2, []) + end + + val (fs1, fs2) = eatMatching (fn ((x1, c1), (x2, c2)) => + not (consNeq env (x1, x2)) + andalso consEq env loc (c1, c2) + andalso consEq env loc (x1, x2)) + (#fields s1, #fields s2) + (*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}), + ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*) + + val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2) + + val hasUnifs = U.Con.exists {kind = fn _ => false, + con = fn L'.CUnif _ => true + | _ => false} + + val (others1, others2) = eatMatching (fn (c1, c2) => + c1 = c2 + orelse (not (hasUnifs c1 andalso hasUnifs c2) + andalso consEq env loc (c1, c2))) (#others s1, #others s2) + (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), + ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) + + fun unsummarize {fields, unifs, others} = + let + val c = (L'.CRecord (k, fields), loc) + + val c = foldl (fn ((c1, _), c2) => (L'.CConcat (c1, c2), loc)) + c unifs + in + foldl (fn (c1, c2) => (L'.CConcat (c1, c2), loc)) + c others + end + + val empties = ([], [], [], [], [], []) + + val (unifs1, fs1, others1, unifs2, fs2, others2) = + case (unifs1, fs1, others1, unifs2, fs2, others2) of + orig as ([(_, r as ref (L'.Unknown f))], [], [], _, _, _) => + let + val c = unsummarize {fields = fs2, others = others2, unifs = unifs2} + in + if occursCon r c orelse not (f c) then + orig + else + (r := L'.Known c; + empties) + end + | orig as (_, _, _, [(_, r as ref (L'.Unknown f))], [], []) => + let + val c = unsummarize {fields = fs1, others = others1, unifs = unifs1} + in + if occursCon r c orelse not (f c) then + orig + else + (r := L'.Known c; + empties) + end + | orig as ([(_, r1 as ref (L'.Unknown f1))], _, [], [(_, r2 as ref (L'.Unknown f2))], _, []) => + if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then + let + val kr = (L'.KRecord k, loc) + val u = cunif env (loc, kr) + + val c1 = (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc) + val c2 = (L'.CConcat ((L'.CRecord (k, fs1), loc), u), loc) + in + if not (f1 c1) orelse not (f2 c2) then + orig + else + (r1 := L'.Known c1; + r2 := L'.Known c2; + empties) + end + else + orig + | orig => orig + + (*val () = eprefaces "Summaries4" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), + ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) + + fun isGuessable (other, fs, unifs) = + let + val c = (L'.CRecord (k, fs), loc) + val c = foldl (fn ((c', _), c) => (L'.CConcat (c', c), loc)) c unifs + in + (guessMap env loc (other, c, GuessFailure); + true) + handle GuessFailure => false + end + + val (fs1, fs2, others1, others2, unifs1, unifs2) = + case (fs1, fs2, others1, others2, unifs1, unifs2) of + ([], _, [other1], [], [], _) => + if isGuessable (other1, fs2, unifs2) then + ([], [], [], [], [], []) + else + (fs1, fs2, others1, others2, unifs1, unifs2) + | (_, [], [], [other2], _, []) => + if isGuessable (other2, fs1, unifs1) then + ([], [], [], [], [], []) + else + (fs1, fs2, others1, others2, unifs1, unifs2) + | _ => (fs1, fs2, others1, others2, unifs1, unifs2) + + val () = if !mayDelay then + () + else + let + val c1 = summaryToCon {fields = fs1, unifs = unifs1, others = others1} + val c2 = summaryToCon {fields = fs2, unifs = unifs2, others = others2} + in + case (c1, c2) of + ((L'.CRecord (_, []), _), (L'.CRecord (_, []), _)) => reducedSummaries := NONE + | _ => reducedSummaries := SOME (p_con env c1, p_con env c2) + end + + (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), + ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) + + val empty = (L'.CRecord (k, []), loc) + fun failure () = + let + val fs2 = #fields s2 + + fun findPointwise fs1 = + case fs1 of + [] => NONE + | (nm1, c1) :: fs1 => + case List.find (fn (nm2, _) => consEq env loc (nm1, nm2)) fs2 of + NONE => findPointwise fs1 + | SOME (_, c2) => + if consEq env loc (c1, c2) then + findPointwise fs1 + else + SOME (nm1, c1, c2, (unifyCons env loc c1 c2; NONE) + handle CUnify (_, _, env', err) => (reducedSummaries := NONE; + SOME (env', err))) + in + raise CUnify' (env, CRecordFailure (unsummarize s1, unsummarize s2, findPointwise (#fields s1))) + end + + fun default () = if !mayDelay then + delayedUnifs := (loc, env, k, s1, s2) :: !delayedUnifs + else + failure () + in + (case (unifs1, fs1, others1, unifs2, fs2, others2) of + (_, [], [], [], [], []) => + app (fn (_, r) => r := L'.Known empty) unifs1 + | ([], [], [], _, [], []) => + app (fn (_, r) => r := L'.Known empty) unifs2 + | (_, _, _, [], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)]) => + let + val c = summaryToCon {fields = fs1, unifs = unifs1, others = others1} + in + if occursCon r c then + (reducedSummaries := NONE; + raise CUnify' (env, COccursCheckFailed (cr, c))) + else + let + val sq = squish nl c + in + if not (f sq) then + default () + else + r := L'.Known sq + end + handle CantSquish => default () + end + | ([], [], [cr as (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _)], _, _, _) => + let + val c = summaryToCon {fields = fs2, unifs = unifs2, others = others2} + in + if occursCon r c then + (reducedSummaries := NONE; + raise CUnify' (env, COccursCheckFailed (cr, c))) + else + let + val sq = squish nl c + in + if not (f sq) then + default () + else + r := L'.Known sq + end + handle CantSquish => default () + end + | _ => default ()) + + (*before eprefaces "Summaries'" [("#1", p_summary env (normalizeRecordSummary env s1)), + ("#2", p_summary env (normalizeRecordSummary env s2))]*) + end + + and guessMap env loc (c1, c2, ex) = + let + fun unfold (dom, ran, f, r, c) = + let + fun unfold (r, c) = + case #1 (hnormCon env c) of + L'.CRecord (_, []) => unifyCons env loc r (L'.CRecord (dom, []), loc) + | L'.CRecord (_, [(x, v)]) => + let + val v' = case dom of + (L'.KUnit, _) => (L'.CUnit, loc) + | _ => cunif env (loc, dom) + in + unifyCons env loc v (L'.CApp (f, v'), loc); + unifyCons env loc r (L'.CRecord (dom, [(x, v')]), loc) + end + | L'.CRecord (_, (x, v) :: rest) => + let + val r1 = cunif env (loc, (L'.KRecord dom, loc)) + val r2 = cunif env (loc, (L'.KRecord dom, loc)) + in + unfold (r1, (L'.CRecord (ran, [(x, v)]), loc)); + unfold (r2, (L'.CRecord (ran, rest), loc)); + unifyCons env loc r (L'.CConcat (r1, r2), loc) + end + | L'.CConcat (c1', c2') => + let + val r1 = cunif env (loc, (L'.KRecord dom, loc)) + val r2 = cunif env (loc, (L'.KRecord dom, loc)) + in + unfold (r1, c1'); + unfold (r2, c2'); + unifyCons env loc r (L'.CConcat (r1, r2), loc) + end + | L'.CUnif (0, _, _, _, ur as ref (L'.Unknown rf)) => + let + val c' = (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), loc), f), loc), r), loc) + in + if not (rf c') then + cunifyError env (CScope (c, c')) + else + ur := L'.Known c' + end + | _ => raise ex + in + unfold (r, c) + end + handle _ => raise ex + in + case (#1 c1, #1 c2) of + (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r), _) => + unfold (dom, ran, f, r, c2) + | (_, L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r)) => + unfold (dom, ran, f, r, c1) + | _ => raise ex + end + + and unifyCons' env loc c1 c2 = + if isUnitCon env c1 andalso isUnitCon env c2 then + () + else + let + (*val befor = Time.now () + val old1 = c1 + val old2 = c2*) + val c1 = hnormCon env c1 + val c2 = hnormCon env c2 + in + unifyCons'' env loc c1 c2 + handle ex => guessMap env loc (c1, c2, ex) + end + + and unifyCons'' env loc (c1All as (c1, _)) (c2All as (c2, _)) = + let + fun err f = raise CUnify' (env, f (c1All, c2All)) + + fun projSpecial1 (c1, n1, onFail) = + let + fun trySnd () = + case #1 (hnormCon env c2All) of + L'.CProj (c2, n2) => + let + fun tryNormal () = + if n1 = n2 then + unifyCons' env loc c1 c2 + else + onFail () + in + case #1 (hnormCon env c2) of + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c2 + val us = map (fn k => cunif' f (loc, k)) ks + in + r := L'.Known (L'.CTuple us, loc); + unifyCons' env loc c1All (List.nth (us, n2 - 1)) + end + | _ => tryNormal ()) + | _ => tryNormal () + end + | _ => onFail () + in + case #1 (hnormCon env c1) of + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c1 + val us = map (fn k => cunif' f (loc, k)) ks + in + r := L'.Known (L'.CTuple us, loc); + unifyCons' env loc (List.nth (us, n1 - 1)) c2All + end + | _ => trySnd ()) + | _ => trySnd () + end + + fun projSpecial2 (c2, n2, onFail) = + case #1 (hnormCon env c2) of + L'.CUnif (0, _, k, _, r as ref (L'.Unknown f)) => + (case #1 (hnormKind k) of + L'.KTuple ks => + let + val loc = #2 c2 + val us = map (fn k => cunif' f (loc, k)) ks + in + r := L'.Known (L'.CTuple us, loc); + unifyCons' env loc c1All (List.nth (us, n2 - 1)) + end + | _ => onFail ()) + | _ => onFail () + + fun isRecord' () = unifyRecordCons env (loc, c1All, c2All) + + fun isRecord () = + case (c1, c2) of + (L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, isRecord') + | (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, isRecord') + | _ => isRecord' () + + fun maybeIsRecord c = + case c of + L'.CRecord _ => isRecord () + | L'.CConcat _ => isRecord () + | _ => err COccursCheckFailed + in + (*eprefaces "unifyCons''" [("c1", p_con env c1All), + ("c2", p_con env c2All)];*) + + (case (c1, c2) of + (L'.CError, _) => () + | (_, L'.CError) => () + + | (L'.CUnif (nl1, loc1, k1, _, r1 as ref (L'.Unknown f1)), L'.CUnif (nl2, loc2, k2, _, r2 as ref (L'.Unknown f2))) => + if r1 = r2 then + if nl1 = nl2 then + () + else + err (fn _ => TooLifty (loc1, loc2)) + else if nl1 = 0 then + (unifyKinds env k1 k2; + if f1 c2All then + r1 := L'.Known c2All + else + err CScope) + else if nl2 = 0 then + (unifyKinds env k1 k2; + if f2 c1All then + r2 := L'.Known c1All + else + err CScope) + else + err (fn _ => TooLifty (loc1, loc2)) + + | (L'.CUnif (0, _, k1, _, r as ref (L'.Unknown f)), _) => + (unifyKinds env k1 (kindof env c2All); + if occursCon r c2All then + maybeIsRecord c2 + else if f c2All then + r := L'.Known c2All + else + err CScope) + | (_, L'.CUnif (0, _, k2, _, r as ref (L'.Unknown f))) => + (unifyKinds env (kindof env c1All) k2; + if occursCon r c1All then + maybeIsRecord c1 + else if f c1All then + r := L'.Known c1All + else + err CScope) + + | (L'.CUnif (nl, _, k1, _, r as ref (L'.Unknown f)), _) => + if occursCon r c2All then + maybeIsRecord c2 + else + (unifyKinds env k1 (kindof env c2All); + let + val sq = squish nl c2All + in + if f sq then + r := L'.Known sq + else + err CScope + end + handle CantSquish => err (fn _ => TooDeep)) + | (_, L'.CUnif (nl, _, k2, _, r as ref (L'.Unknown f))) => + if occursCon r c1All then + maybeIsRecord c1 + else + (unifyKinds env (kindof env c1All) k2; + let + val sq = squish nl c1All + in + if f sq then + r := L'.Known sq + else + err CScope + end + handle CantSquish => err (fn _ => TooDeep)) + + | (L'.CRecord _, _) => isRecord () + | (_, L'.CRecord _) => isRecord () + | (L'.CConcat _, _) => isRecord () + | (_, L'.CConcat _) => isRecord () + + + | (L'.CUnit, L'.CUnit) => () + + | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => + (unifyCons' env loc d1 d2; + unifyCons' env loc r1 r2) + | (L'.TCFun (expl1, x1, d1, r1), L'.TCFun (expl2, _, d2, r2)) => + if expl1 <> expl2 then + err CExplicitness + else + (unifyKinds env d1 d2; + let + (*val befor = Time.now ()*) + val env' = E.pushCRel env x1 d1 + in + (*TextIO.print ("E.pushCRel: " + ^ LargeReal.toString (Time.toReal (Time.- (Time.now (), befor))) + ^ "\n");*) + unifyCons' env' loc r1 r2 + end) + | (L'.TRecord r1, L'.TRecord r2) => unifyCons' env loc r1 r2 + | (L'.TDisjoint (c1, d1, e1), L'.TDisjoint (c2, d2, e2)) => + (unifyCons' env loc c1 c2; + unifyCons' env loc d1 d2; + unifyCons' env loc e1 e2) + + | (L'.CRel n1, L'.CRel n2) => + if n1 = n2 then + () + else + err CIncompatible + | (L'.CNamed n1, L'.CNamed n2) => + if n1 = n2 then + () + else + err CIncompatible + + | (L'.CApp (d1, r1), L'.CApp (d2, r2)) => + (unifyCons' env loc d1 d2; + unifyCons' env loc r1 r2) + | (L'.CAbs (x1, k1, c1), L'.CAbs (_, k2, c2)) => + (unifyKinds env k1 k2; + unifyCons' (E.pushCRel env x1 k1) loc c1 c2) + + | (L'.CName n1, L'.CName n2) => + if n1 = n2 then + () + else + err CIncompatible + + | (L'.CModProj (n1, ms1, x1), L'.CModProj (n2, ms2, x2)) => + if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then + () + else + err CIncompatible + + | (L'.CTuple cs1, L'.CTuple cs2) => + ((ListPair.appEq (fn (c1, c2) => unifyCons' env loc c1 c2) (cs1, cs2)) + handle ListPair.UnequalLengths => err CIncompatible) + + | (L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, fn () => err CIncompatible) + | (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, fn () => err CIncompatible) + + | (L'.CTuple cs, L'.CRel x) => + (case hnormKind (kindof env c2All) of + (L'.KTuple ks, _) => + if length cs <> length ks then + err CIncompatible + else + let + fun rightProjs (cs, n) = + case cs of + c :: cs' => + (case hnormCon env c of + (L'.CProj ((L'.CRel x', _), n'), _) => + x' = x andalso n' = n andalso rightProjs (cs', n+1) + | _ => false) + | [] => true + in + if rightProjs (cs, 1) then + () + else + err CIncompatible + end + | _ => err CIncompatible) + | (L'.CRel x, L'.CTuple cs) => + unifyCons'' env loc c2All c1All + + | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) => + (unifyKinds env dom1 dom2; + unifyKinds env ran1 ran2) + + | (L'.CKAbs (x, c1), L'.CKAbs (_, c2)) => + unifyCons' (E.pushKRel env x) loc c1 c2 + | (L'.CKApp (c1, k1), L'.CKApp (c2, k2)) => + (unifyKinds env k1 k2; + unifyCons' env loc c1 c2) + | (L'.TKFun (x, c1), L'.TKFun (_, c2)) => + unifyCons' (E.pushKRel env x) loc c1 c2 + + | _ => err CIncompatible)(*; + eprefaces "/unifyCons''" [("c1", p_con env c1All), + ("c2", p_con env c2All)]*) + end + + and unifyCons env loc c1 c2 = + ((*Print.prefaces "uc" [("c1", p_con env c1), + ("c2", p_con env c2)];*) + unifyCons' env loc c1 c2) + handle CUnify' (env', err) => raise CUnify (c1, c2, env', err) + | KUnify (arg as {3 = env', ...}) => raise CUnify (c1, c2, env', CKind arg) + + fun checkCon env e c1 c2 = + unifyCons env (#2 e) c1 c2 + handle CUnify (c1, c2, env', err) => + expError env (Unify (e, c1, c2, env', err)) + + fun checkPatCon env p c1 c2 = + unifyCons env (#2 p) c1 c2 + handle CUnify (c1, c2, env', err) => + expError env (PatUnify (p, c1, c2, env', err)) + + fun primType env p = + case p of + P.Int _ => !int + | P.Float _ => !float + | P.String _ => !string + | P.Char _ => !char + + datatype constraint = + Disjoint of D.goal + | TypeClass of E.env * L'.con * L'.exp option ref * ErrorMsg.span + + fun relocConstraint loc c = + case c of + Disjoint (_, a, b, c, d) => Disjoint (loc, a, b, c, d) + | TypeClass (a, b, c, _) => TypeClass (a, b, c, loc) + + val enD = map Disjoint + + fun isClassOrFolder env cl = + E.isClass env cl + orelse case hnormCon env cl of + (L'.CKApp (cl, _), _) => + (case hnormCon env cl of + (L'.CModProj (top_n, [], "folder"), _) => top_n = !top_r + | _ => false) + | _ => false + + fun subConInCon env x y = + ElabOps.subConInCon x y + handle SubUnif => (cunifyError env (TooUnify (#2 x, y)); + cerror) + + fun elabHead (env, denv) infer (e as (_, loc)) t = + let + fun unravelKind (t, e) = + case hnormCon env t of + (L'.TKFun (x, t'), _) => + let + val u = kunif env loc + + val t'' = subKindInCon (0, u) t' + in + unravelKind (t'', (L'.EKApp (e, u), loc)) + end + | t => (e, t, []) + + fun unravel (t, e) = + case hnormCon env t of + (L'.TKFun (x, t'), _) => + let + val u = kunif env loc + + val t'' = subKindInCon (0, u) t' + in + unravel (t'', (L'.EKApp (e, u), loc)) + end + | (L'.TCFun (L'.Implicit, x, k, t'), _) => + let + val u = cunif env (loc, k) + + val t'' = subConInCon env (0, u) t' + in + unravel (t'', (L'.ECApp (e, u), loc)) + end + | (L'.TFun (dom, ran), _) => + let + fun default () = (e, t, []) + + fun isInstance () = + if infer <> L.TypesOnly then + let + val r = ref NONE + val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc)) + in + (e, t, TypeClass (env, dom, r, loc) :: gs) + end + else + default () + + fun hasInstance c = + case hnormCon env c of + (L'.TRecord c, _) => U.Con.exists {kind = fn _ => false, + con = fn c => + isClassOrFolder env (hnormCon env (c, loc))} c + | c => + let + fun findHead c = + case #1 c of + L'.CApp (f, _) => findHead f + | _ => c + + val cl = hnormCon env (findHead c) + in + isClassOrFolder env cl + end + in + if hasInstance dom then + isInstance () + else + default () + end + | (L'.TDisjoint (r1, r2, t'), loc) => + if infer <> L.TypesOnly then + let + val gs = D.prove env denv (r1, r2, #2 e) + val (e, t, gs') = unravel (t', e) + in + (e, t, enD gs @ gs') + end + else + (e, t, []) + | t => (e, t, []) + + val (e, t, gs) = case infer of + L.DontInfer => unravelKind (t, e) + | _ => unravel (t, e) + in + ((#1 e, loc), (#1 t, loc), map (relocConstraint loc) gs) + end + +fun elabPat (pAll as (p, loc), (env, bound)) = + let + val terror = (L'.CError, loc) + val perror = (L'.PVar ("_", terror), loc) + val pterror = (perror, terror) + val rerror = (pterror, (env, bound)) + + fun pcon (pc, po, xs, to, dn, dk) = + case (po, to) of + (NONE, SOME _) => (expError env (PatHasNoArg loc); + rerror) + | (SOME _, NONE) => (expError env (PatHasArg loc); + rerror) + | (NONE, NONE) => + let + val k = (L'.KType, loc) + val unifs = map (fn _ => cunif env (loc, k)) xs + val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs + in + (((L'.PCon (dk, pc, unifs, NONE), loc), dn), + (env, bound)) + end + | (SOME p, SOME t) => + let + val ((p', pt), (env, bound)) = elabPat (p, (env, bound)) + + val k = (L'.KType, loc) + val unifs = map (fn _ => cunif env (loc, k)) xs + val nxs = length unifs - 1 + val t = ListUtil.foldli (fn (i, u, t) => subConInCon env (nxs - i, + E.mliftConInCon (nxs - i) u) t) t unifs + val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs + in + ignore (checkPatCon env p' pt t); + (((L'.PCon (dk, pc, unifs, SOME p'), loc), dn), + (env, bound)) + end + in + case p of + L.PVar x => + let + val t = if x <> "_" andalso SS.member (bound, x) then + (expError env (DuplicatePatternVariable (loc, x)); + terror) + else + cunif env (loc, (L'.KType, loc)) + in + (((L'.PVar (x, t), loc), t), + (E.pushERel env x t, SS.add (bound, x))) + end + | L.PPrim p => (((L'.PPrim p, loc), primType env p), + (env, bound)) + | L.PCon ([], x, po) => + (case E.lookupConstructor env x of + NONE => (expError env (UnboundConstructor (loc, [], x)); + rerror) + | SOME (dk, n, xs, to, dn) => pcon (L'.PConVar n, po, xs, to, (L'.CNamed dn, loc), dk)) + | L.PCon (m1 :: ms, x, po) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + rerror) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "elabPat: Unknown substructure" + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectConstructor env {str = str, sgn = sgn, field = x} of + NONE => (expError env (UnboundConstructor (loc, m1 :: ms, x)); + rerror) + | SOME (dk, _, xs, to, dn) => pcon (L'.PConProj (n, ms, x), po, xs, to, dn, dk) + end) + + | L.PRecord (xps, flex) => + let + val (xpts, (env, bound, _)) = + ListUtil.foldlMap (fn ((x, p), (env, bound, fbound)) => + let + val ((p', t), (env, bound)) = elabPat (p, (env, bound)) + in + if SS.member (fbound, x) then + expError env (DuplicatePatField (loc, x)) + else + (); + ((x, p', t), (env, bound, SS.add (fbound, x))) + end) + (env, bound, SS.empty) xps + + val k = (L'.KType, loc) + val c = (L'.CRecord (k, map (fn (x, _, t) => ((L'.CName x, loc), t)) xpts), loc) + val c = + if flex then + (L'.CConcat (c, cunif env (loc, (L'.KRecord k, loc))), loc) + else + c + in + (((L'.PRecord xpts, loc), + (L'.TRecord c, loc)), + (env, bound)) + end + + | L.PAnnot (p, t) => + let + val ((p', pt), (env, bound)) = elabPat (p, (env, bound)) + val (t', k, _) = elabCon (env, D.empty) t + in + checkPatCon env p' pt t'; + ((p', t'), (env, bound)) + end + end + +(* This exhaustiveness checking follows Luc Maranget's paper "Warnings for pattern matching." *) +fun exhaustive (env, t, ps, loc) = + let + val pwild = L'.PVar ("_", t) + + fun fail n = raise Fail ("Elaborate.exhaustive: Impossible " ^ Int.toString n) + + fun patConNum pc = + case pc of + L'.PConVar n => n + | L'.PConProj (m1, ms, x) => + let + val (str, sgn) = E.chaseMpath env (m1, ms) + in + case E.projectConstructor env {str = str, sgn = sgn, field = x} of + NONE => raise Fail "exhaustive: Can't project datatype" + | SOME (_, n, _, _, _) => n + end + + fun nameOfNum (t, n) = + case t of + L'.CModProj (m1, ms, x) => + let + val (str, sgn) = E.chaseMpath env (m1, ms) + in + case E.projectDatatype env {str = str, sgn = sgn, field = x} of + NONE => raise Fail "exhaustive: Can't project datatype" + | SOME (_, cons) => + case ListUtil.search (fn (name, n', _) => + if n' = n then + SOME name + else + NONE) cons of + NONE => fail 9 + | SOME name => L'.PConProj (m1, ms, name) + end + | _ => L'.PConVar n + + fun S (args, c, P) = + List.mapPartial + (fn [] => fail 1 + | p1 :: ps => + let + val loc = #2 p1 + + fun wild () = + SOME (map (fn _ => (pwild, loc)) args @ ps) + in + case #1 p1 of + L'.PPrim _ => NONE + | L'.PCon (_, c', _, NONE) => + if patConNum c' = c then + SOME ps + else + NONE + | L'.PCon (_, c', _, SOME p) => + if patConNum c' = c then + SOME (p :: ps) + else + NONE + | L'.PRecord xpts => + SOME (map (fn x => + case ListUtil.search (fn (x', p, _) => + if x = x' then + SOME p + else + NONE) xpts of + NONE => (pwild, loc) + | SOME p => p) args @ ps) + | L'.PVar _ => wild () + end) + P + + fun D P = + List.mapPartial + (fn [] => fail 2 + | (p1, _) :: ps => + case p1 of + L'.PVar _ => SOME ps + | L'.PPrim _ => NONE + | L'.PCon _ => NONE + | L'.PRecord _ => NONE) + P + + fun I (P, q) = + (*(prefaces "I" [("P", p_list (fn P' => box [PD.string "[", p_list (p_pat env) P', PD.string "]"]) P), + ("q", p_list (p_con env) q)];*) + case q of + [] => (case P of + [] => SOME [] + | _ => NONE) + | q1 :: qs => + let + val loc = #2 q1 + + fun unapp (t, acc) = + case #1 t of + L'.CApp (t, arg) => unapp (t, arg :: acc) + | _ => (t, rev acc) + + val (t1, args) = unapp (hnormCon env q1, []) + val t1 = hnormCon env t1 + fun doSub t = foldl (fn (arg, t) => subConInCon env (0, arg) t) t args + + fun dtype (dtO, names) = + let + val nameSet = IS.addList (IS.empty, names) + val nameSet = foldl (fn (ps, nameSet) => + case ps of + [] => fail 4 + | (L'.PCon (_, pc, _, _), _) :: _ => + (IS.delete (nameSet, patConNum pc) + handle NotFound => nameSet) + | _ => nameSet) + nameSet P + in + nameSet + end + + fun default () = (NONE, IS.singleton 0, []) + + val (dtO, unused, cons) = + case #1 t1 of + L'.CNamed n => + let + val dt = E.lookupDatatype env n + val cons = E.constructors dt + in + (SOME dt, + dtype (SOME dt, map #2 cons), + map (fn (_, n, co) => + (n, + case co of + NONE => [] + | SOME t => [("", doSub t)])) cons) + end + | L'.CModProj (m1, ms, x) => + let + val (str, sgn) = E.chaseMpath env (m1, ms) + in + case E.projectDatatype env {str = str, sgn = sgn, field = x} of + NONE => default () + | SOME (_, cons) => + (NONE, + dtype (NONE, map #2 cons), + map (fn (s, _, co) => + (patConNum (L'.PConProj (m1, ms, s)), + case co of + NONE => [] + | SOME t => [("", doSub t)])) cons) + end + | L'.TRecord t => + (case #1 (hnormCon env t) of + L'.CRecord (_, xts) => + let + val xts = map (fn ((L'.CName x, _), co) => SOME (x, co) + | _ => NONE) xts + in + if List.all Option.isSome xts then + let + val xts = List.mapPartial (fn x => x) xts + val xts = ListMergeSort.sort (fn ((x1, _), (x2, _)) => + String.compare (x1, x2) = GREATER) xts + in + (NONE, IS.empty, [(0, xts)]) + end + else + default () + end + | _ => default ()) + | _ => default () + in + if IS.isEmpty unused then + let + fun recurse cons = + case cons of + [] => NONE + | (name, args) :: cons => + case I (S (map #1 args, name, P), + map #2 args @ qs) of + NONE => recurse cons + | SOME ps => + let + val nargs = length args + val argPs = List.take (ps, nargs) + val restPs = List.drop (ps, nargs) + + val p = case name of + 0 => L'.PRecord (ListPair.map + (fn ((name, t), p) => (name, p, t)) + (args, argPs)) + | _ => L'.PCon (L'.Default, nameOfNum (#1 t1, name), [], + case argPs of + [] => NONE + | [p] => SOME p + | _ => fail 3) + in + SOME ((p, loc) :: restPs) + end + in + recurse cons + end + else + case I (D P, qs) of + NONE => NONE + | SOME ps => + let + val p = case cons of + [] => pwild + | (0, _) :: _ => pwild + | _ => + case IS.find (fn _ => true) unused of + NONE => fail 6 + | SOME name => + case ListUtil.search (fn (name', args) => + if name = name' then + SOME (name', args) + else + NONE) cons of + SOME (n, []) => + L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], NONE) + | SOME (n, [_]) => + L'.PCon (L'.Default, nameOfNum (#1 t1, n), [], SOME (pwild, loc)) + | _ => fail 7 + in + SOME ((p, loc) :: ps) + end + end + in + case I (map (fn x => [x]) ps, [t]) of + NONE => NONE + | SOME [p] => SOME p + | _ => fail 7 + end + +fun unmodCon env (c, loc) = + case c of + L'.CNamed n => + (case E.lookupCNamed env n of + (_, _, SOME (c as (L'.CModProj _, _))) => unmodCon env c + | _ => (c, loc)) + | L'.CModProj (m1, ms, x) => + let + val (str, sgn) = E.chaseMpath env (m1, ms) + in + case E.projectCon env {str = str, sgn = sgn, field = x} of + NONE => raise Fail "unmodCon: Can't projectCon" + | SOME (_, SOME (c as (L'.CModProj _, _))) => unmodCon env c + | _ => (c, loc) + end + | _ => (c, loc) + +fun normClassKey env c = + let + val c = hnormCon env c + in + case #1 c of + L'.CApp (c1, c2) => + let + val c1 = normClassKey env c1 + val c2 = normClassKey env c2 + in + (L'.CApp (c1, c2), #2 c) + end + | L'.CRecord (k, xcs) => (L'.CRecord (k, map (fn (x, c) => (normClassKey env x, + normClassKey env c)) xcs), #2 c) + | _ => unmodCon env c + end + +fun normClassConstraint env (c, loc) = + case c of + L'.CApp (f, x) => + let + val f = normClassKey env f + val x = normClassKey env x + in + (L'.CApp (f, x), loc) + end + | L'.TFun (c1, c2) => + let + val c1 = normClassConstraint env c1 + val c2 = normClassConstraint env c2 + in + (L'.TFun (c1, c2), loc) + end + | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) + | L'.CUnif (nl, _, _, _, ref (L'.Known c)) => normClassConstraint env (E.mliftConInCon nl c) + | _ => unmodCon env (c, loc) + +fun findHead e e' = + let + fun findHead (e, _) = + case e of + L.EVar (_, _, infer) => + let + fun findHead' (e, _) = + case e of + L'.ENamed _ => true + | L'.EModProj _ => true + | L'.ERel _ => true + | L'.EApp (e, _) => findHead' e + | L'.ECApp (e, _) => findHead' e + | L'.EKApp (e, _) => findHead' e + | _ => false + in + if findHead' e' then + SOME infer + else + NONE + end + | L.EApp (e, _) => findHead e + | L.ECApp (e, _) => findHead e + | L.EDisjointApp e => findHead e + | _ => NONE + in + findHead e + end + +datatype needed = Needed of {Cons : (L'.kind * int) SM.map, + NextCon : int, + Constraints : (E.env * (L'.con * L'.con) * ErrorMsg.span) list, + Vals : SS.set, + Mods : (E.env * needed) SM.map} + +fun ncons (Needed r) = map (fn (k, (v, _)) => (k, v)) + (ListMergeSort.sort (fn ((_, (_, n1)), (_, (_, n2))) => n1 > n2) + (SM.listItemsi (#Cons r))) +fun nconstraints (Needed r) = #Constraints r +fun nvals (Needed r) = #Vals r +fun nmods (Needed r) = #Mods r + +val nempty = Needed {Cons = SM.empty, + NextCon = 0, + Constraints = nil, + Vals = SS.empty, + Mods = SM.empty} + +fun naddCon (r : needed, k, v) = + let + val Needed r = r + in + Needed {Cons = SM.insert (#Cons r, k, (v, #NextCon r)), + NextCon = #NextCon r + 1, + Constraints = #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun naddConstraint (r : needed, v) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + NextCon = #NextCon r, + Constraints = v :: #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun naddVal (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + NextCon = #NextCon r, + Constraints = #Constraints r, + Vals = SS.add (#Vals r, k), + Mods = #Mods r} + end + +fun naddMod (r : needed, k, v) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + NextCon = #NextCon r, + Constraints = #Constraints r, + Vals = #Vals r, + Mods = SM.insert (#Mods r, k, v)} + end + +fun ndelCon (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #1 (SM.remove (#Cons r, k)) handle NotFound => #Cons r, + NextCon = #NextCon r, + Constraints = #Constraints r, + Vals = #Vals r, + Mods = #Mods r} + end + +fun ndelVal (r : needed, k) = + let + val Needed r = r + in + Needed {Cons = #Cons r, + NextCon = #NextCon r, + Constraints = #Constraints r, + Vals = SS.delete (#Vals r, k) handle NotFound => #Vals r, + Mods = #Mods r} + end + +fun chaseUnifs c = + case #1 c of + L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c + | _ => c + +val consEqSimple = + let + fun ces env (c1 : L'.con, c2 : L'.con) = + let + val c1 = hnormCon env c1 + val c2 = hnormCon env c2 + in + case (#1 c1, #1 c2) of + (L'.CRel n1, L'.CRel n2) => n1 = n2 + | (L'.CNamed n1, L'.CNamed n2) => + n1 = n2 orelse + (case #3 (E.lookupCNamed env n1) of + SOME (L'.CNamed n2', _) => n2' = n1 + | _ => false) + | (L'.CModProj n1, L'.CModProj n2) => n1 = n2 + | (L'.CApp (f1, x1), L'.CApp (f2, x2)) => ces env (f1, f2) andalso ces env (x1, x2) + | (L'.CAbs (x1, k1, c1), L'.CAbs (_, _, c2)) => ces (E.pushCRel env x1 k1) (c1, c2) + | (L'.CName x1, L'.CName x2) => x1 = x2 + | (L'.CRecord (_, xts1), L'.CRecord (_, xts2)) => + ListPair.all (fn ((x1, t1), (x2, t2)) => + ces env (x1, x2) andalso ces env (t2, t2)) (xts1, xts2) + | (L'.CConcat (x1, y1), L'.CConcat (x2, y2)) => + ces env (x1, x2) andalso ces env (y1, y2) + | (L'.CMap _, L'.CMap _) => true + | (L'.CUnit, L'.CUnit) => true + | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) + | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 + | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + + | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => ces env (d1, d2) andalso ces env (r1, r2) + | (L'.TRecord c1, L'.TRecord c2) => ces env (c1, c2) + + | _ => false + end + in + ces + end + + +fun elabExp (env, denv) (eAll as (e, loc)) = + let + (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*) + (*val befor = Time.now ()*) + + val r = case e of + L.EAnnot (e, t) => + let + val (e', et, gs1) = elabExp (env, denv) e + val (t', _, gs2) = elabCon (env, denv) t + in + checkCon env e' et t'; + (e', t', gs1 @ enD gs2) + end + + | L.EPrim p => ((L'.EPrim p, loc), primType env p, []) + | L.EVar ([], s, infer) => + (case E.lookupE env s of + E.NotBound => + (expError env (UnboundExp (loc, s)); + (eerror, cerror, [])) + | E.Rel (n, t) => elabHead (env, denv) infer (L'.ERel n, loc) t + | E.Named (n, t) => elabHead (env, denv) infer (L'.ENamed n, loc) t) + | L.EVar (m1 :: ms, s, infer) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + (eerror, cerror, [])) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + in + elabHead (env, denv) infer (L'.EModProj (n, ms, s), loc) t + end) + + | L.EWild => + let + val r = ref NONE + val c = cunif env (loc, (L'.KType, loc)) + in + ((L'.EUnif r, loc), c, [TypeClass (env, c, r, loc)]) + end + + | L.EApp (e1, e2) => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + + val (e2', t2, gs2) = elabExp (env, denv) e2 + + val dom = cunif env (loc, ktype) + val ran = cunif env (loc, ktype) + val t = (L'.TFun (dom, ran), loc) + + val () = checkCon env e1' t1 t + val () = checkCon env e2' t2 dom + + val ef = (L'.EApp (e1', e2'), loc) + val (ef, et, gs3) = + case findHead e1 e1' of + NONE => (ef, (#1 (chaseUnifs ran), loc), []) + | SOME infer => elabHead (env, denv) infer ef ran + in + (ef, et, gs1 @ gs2 @ gs3) + end + | L.EAbs (x, to, e) => + let + val (t', gs1) = case to of + NONE => (cunif env (loc, ktype), []) + | SOME t => + let + val (t', tk, gs) = elabCon (env, denv) t + in + checkKind env t' tk ktype; + (t', gs) + end + val dom = normClassConstraint env t' + val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e + in + ((L'.EAbs (x, t', et, e'), loc), + (L'.TFun (t', et), loc), + enD gs1 @ gs2) + end + | L.ECApp (e, c) => + let + val (e', et, gs1) = elabExp (env, denv) e + + val oldEt = et + val (c', ck, gs2) = elabCon (env, denv) c + val (et', _) = hnormCon env et + in + case et' of + L'.CError => (eerror, cerror, []) + | L'.TCFun (_, x, k, eb) => + let + val () = checkKind env c' ck k + val eb' = subConInCon env (0, c') eb + + val ef = (L'.ECApp (e', c'), loc) + val (ef, eb', gs3) = + case findHead e e' of + NONE => (ef, eb', []) + | SOME infer => elabHead (env, denv) infer ef eb' + in + (*prefaces "Elab ECApp" [("e", SourcePrint.p_exp eAll), + ("et", p_con env oldEt), + ("x", PD.string x), + ("eb", p_con (E.pushCRel env x k) eb), + ("c", p_con env c'), + ("eb'", p_con env eb')];*) + (ef, (#1 eb', loc), gs1 @ enD gs2 @ gs3) + end + + | _ => + (expError env (WrongForm ("constructor function", e', et)); + (eerror, cerror, [])) + end + | L.ECAbs (expl, x, k, e) => + let + val expl' = elabExplicitness expl + val k' = elabKind env k + + val env' = E.pushCRel env x k' + val (e', et, gs) = elabExp (env', D.enter denv) e + in + ((L'.ECAbs (expl', x, k', e'), loc), + (L'.TCFun (expl', x, k', et), loc), + gs) + end + | L.EKAbs (x, e) => + let + val env' = E.pushKRel env x + val (e', et, gs) = elabExp (env', denv) e + in + ((L'.EKAbs (x, e'), loc), + (L'.TKFun (x, et), loc), + gs) + end + + | L.EDisjoint (c1, c2, e) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + + val ku1 = kunif env loc + val ku2 = kunif env loc + + val denv' = D.assert env denv (c1', c2') + val (e', t, gs3) = elabExp (env, denv') e + in + checkKind env c1' k1 (L'.KRecord ku1, loc); + checkKind env c2' k2 (L'.KRecord ku2, loc); + + (e', (L'.TDisjoint (c1', c2', t), loc), enD gs1 @ enD gs2 @ gs3) + end + | L.EDisjointApp e => + let + val (e', t, gs1) = elabExp (env, denv) e + + val k1 = kunif env loc + val c1 = cunif env (loc, (L'.KRecord k1, loc)) + val k2 = kunif env loc + val c2 = cunif env (loc, (L'.KRecord k2, loc)) + val t' = cunif env (loc, ktype) + val () = checkCon env e' t (L'.TDisjoint (c1, c2, t'), loc) + val gs2 = D.prove env denv (c1, c2, loc) + in + (e', (#1 (chaseUnifs t'), loc), enD gs2 @ gs1) + end + + | L.ERecord (xes, flex) => + let + val () = if flex then + expError env (IllegalFlex eAll) + else + () + + val (xes', gs) = ListUtil.foldlMap (fn ((x, e), gs) => + let + val (x', xk, gs1) = elabCon (env, denv) x + val (e', et, gs2) = elabExp (env, denv) e + in + checkKind env x' xk kname; + ((x', e', et), enD gs1 @ gs2 @ gs) + end) + [] xes + + val k = (L'.KType, loc) + + fun prove (xets, gs) = + case xets of + [] => gs + | (x, _, t) :: rest => + let + val xc = (x, t) + val r1 = (L'.CRecord (k, [xc]), loc) + val gs = foldl (fn ((x', _, t'), gs) => + let + val xc' = (x', t') + val r2 = (L'.CRecord (k, [xc']), loc) + in + D.prove env denv (r1, r2, loc) @ gs + end) + gs rest + in + prove (rest, gs) + end + + val gsD = List.mapPartial (fn Disjoint d => SOME d | _ => NONE) gs + val gsO = List.filter (fn Disjoint _ => false | _ => true) gs + in + (*TextIO.print ("|gsO| = " ^ Int.toString (length gsO) ^ "\n");*) + ((L'.ERecord xes', loc), + (L'.TRecord (L'.CRecord (ktype, map (fn (x', _, et) => (x', et)) xes'), loc), loc), + enD (prove (xes', gsD)) @ gsO) + end + + | L.EField (e, c) => + let + val (e', et, gs1) = elabExp (env, denv) e + val (c', ck, gs2) = elabCon (env, denv) c + + val ft = cunif env (loc, ktype) + val rest = cunif env (loc, ktype_record) + val first = (L'.CRecord (ktype, [(c', ft)]), loc) + val () = checkCon env e' et + (L'.TRecord (L'.CConcat (first, rest), loc), loc); + val gs3 = D.prove env denv (first, rest, loc) + in + ((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3) + end + + | L.EConcat (e1, e2) => + let + val (e1', e1t, gs1) = elabExp (env, denv) e1 + val (e2', e2t, gs2) = elabExp (env, denv) e2 + + val r1 = cunif env (loc, ktype_record) + val r2 = cunif env (loc, ktype_record) + + val () = checkCon env e1' e1t (L'.TRecord r1, loc) + val () = checkCon env e2' e2t (L'.TRecord r2, loc) + + val gs3 = D.prove env denv (r1, r2, loc) + in + ((L'.EConcat (e1', r1, e2', r2), loc), + (L'.TRecord ((L'.CConcat (r1, r2), loc)), loc), + gs1 @ gs2 @ enD gs3) + end + | L.ECut (e, c) => + let + val (e', et, gs1) = elabExp (env, denv) e + val (c', ck, gs2) = elabCon (env, denv) c + + val ft = cunif env (loc, ktype) + val rest = cunif env (loc, ktype_record) + val first = (L'.CRecord (ktype, [(c', ft)]), loc) + + val () = checkCon env e' et + (L'.TRecord (L'.CConcat (first, rest), loc), loc) + + val gs3 = D.prove env denv (first, rest, loc) + in + checkKind env c' ck kname; + ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc), + gs1 @ enD gs2 @ enD gs3) + end + | L.ECutMulti (e, c) => + let + val (e', et, gs1) = elabExp (env, denv) e + val (c', ck, gs2) = elabCon (env, denv) c + + val rest = cunif env (loc, ktype_record) + + val () = checkCon env e' et + (L'.TRecord (L'.CConcat (c', rest), loc), loc) + + val gs3 = D.prove env denv (c', rest, loc) + in + checkKind env c' ck (L'.KRecord ktype, loc); + ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc), + gs1 @ enD gs2 @ enD gs3) + end + + | L.ECase (e, pes) => + let + val (e', et, gs1) = elabExp (env, denv) e + val result = cunif env (loc, (L'.KType, loc)) + val (pes', gs) = ListUtil.foldlMap + (fn ((p, e), gs) => + let + val ((p', pt), (env, _)) = elabPat (p, (env, SS.empty)) + + val (e', et', gs1) = elabExp (env, denv) e + in + checkPatCon env p' pt et; + checkCon env e' et' result; + ((p', e'), gs1 @ gs) + end) + gs1 pes + in + case exhaustive (env, et, map #1 pes', loc) of + NONE => () + | SOME p => if !mayDelay then + delayedExhaustives := (env, et, map #1 pes', loc) :: !delayedExhaustives + else + expError env (Inexhaustive (loc, p)); + + ((L'.ECase (e', pes', {disc = et, result = result}), loc), result, gs) + end + + | L.ELet (eds, e) => + let + val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds + val (e, t, gs2) = elabExp (env, denv) e + in + ((L'.ELet (eds, e, t), loc), t, gs1 @ gs2) + end + in + (*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*) + r + end + +and elabEdecl denv (dAll as (d, loc), (env, gs)) = + let + val r = + case d of + L.EDVal (p, e) => + let + val ((p', pt), (env', _)) = elabPat (p, (env, SS.empty)) + val (e', et, gs1) = elabExp (env, denv) e + + val () = checkCon env e' et pt + + val env' = E.patBinds env p' + (* Redo to get proper detection of type class witnesses *) + + val pt = normClassConstraint env pt + in + case exhaustive (env, et, [p'], loc) of + NONE => () + | SOME p => if !mayDelay then + delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives + else + expError env (Inexhaustive (loc, p)); + + ((L'.EDVal (p', pt, e'), loc), (env', gs1 @ gs)) + end + | L.EDValRec vis => + let + fun allowable (e, _) = + case e of + L.EAbs _ => true + | L.ECAbs (_, _, _, e) => allowable e + | L.EKAbs (_, e) => allowable e + | L.EDisjoint (_, _, e) => allowable e + | _ => false + + val (vis, gs) = ListUtil.foldlMap + (fn ((x, co, e), gs) => + let + val (c', _, gs1) = case co of + NONE => (cunif env (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + in + ((x, c', e), enD gs1 @ gs) + end) gs vis + + val env = foldl (fn ((x, c', _), env) => E.pushERel env x c') env vis + + val (vis, gs) = ListUtil.foldlMap (fn ((x, c', e), gs) => + let + val (e', et, gs1) = elabExp (env, denv) e + in + checkCon env e' et c'; + if allowable e then + () + else + expError env (IllegalRec (x, e')); + ((x, c', e'), gs1 @ gs) + end) gs vis + in + ((L'.EDValRec vis, loc), (env, gs)) + end + in + r + end + +val hnormSgn = E.hnormSgn + +fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) +fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan) +fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) +fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) +fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) + +fun patVarsOf (p : L.pat) = + case #1 p of + L.PVar x => [x] + | L.PPrim _ => [] + | L.PCon (_, _, NONE) => [] + | L.PCon (_, _, SOME p) => patVarsOf p + | L.PRecord (xps, _) => ListUtil.mapConcat (fn (_, p) => patVarsOf p) xps + | L.PAnnot (p', _) => patVarsOf p' + +fun dopenConstraints (loc, env, denv) {str, strs} = + case E.lookupStr env str of + NONE => (strError env (UnboundStr (loc, str)); + denv) + | SOME (n, sgn) => + let + val (st, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {str = str, sgn = sgn, field = m} of + NONE => (strError env (UnboundStr (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) strs + + fun collect first (st, sgn) = + case E.projectConstraints env {sgn = sgn, str = st} of + NONE => [] + | SOME cs => + case #1 (hnormSgn env sgn) of + L'.SgnConst sgis => + foldl (fn (sgi, cs) => + case #1 sgi of + L'.SgiStr (L'.Import, x, _, _) => + (case E.projectStr env {sgn = sgn, str = st, field = x} of + NONE => raise Fail "Elaborate: projectStr in collect" + | SOME sgn' => + List.revAppend (collect false ((L'.StrProj (st, x), loc), sgn'), + cs)) + | _ => cs) cs sgis + | _ => cs + in + foldl (fn ((c1, c2), denv) => + D.assert env denv (c1, c2)) denv (collect true (st, sgn)) + end + +fun tcdump env = + Print.preface("Instances", p_list_sep Print.PD.newline + (fn (cl, ls) => + box [p_con env cl, + box [Print.PD.string "{", + p_list (fn (t, e) => + box [p_exp env e, + Print.PD.string " : ", + p_con env t]) ls, + Print.PD.string "}"]]) + (E.listClasses env)) + +fun elabSgn_item ((sgi, loc), (env, denv, gs)) = + ((*Print.preface ("elabSgi", SourcePrint.p_sgn_item (sgi, loc));*) + case sgi of + L.SgiConAbs (x, k) => + let + val k' = elabKind env k + + val (env', n) = E.pushCNamed env x k' NONE + in + ([(L'.SgiConAbs (x, n, k'), loc)], (env', denv, gs)) + end + + | L.SgiCon (x, ko, c) => + let + val k' = case ko of + NONE => kunif env loc + | SOME k => elabKind env k + + val (c', ck, gs') = elabCon (env, denv) c + val (env', n) = E.pushCNamed env x k' (SOME c') + in + checkKind env c' ck k'; + + ([(L'.SgiCon (x, n, k', c'), loc)], (env', denv, gs' @ gs)) + end + + | L.SgiDatatype dts => + let + val k = (L'.KType, loc) + + val (dts, env) = ListUtil.foldlMap (fn ((x, xs, xcs), env) => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val (env, n) = E.pushCNamed env x k' NONE + in + ((x, n, xs, xcs), env) + end) + env dts + + val (dts, env) = ListUtil.foldlMap + (fn ((x, n, xs, xcs), env) => + let + val t = (L'.CNamed n, loc) + val nxs = length xs - 1 + val t = ListUtil.foldli (fn (i, _, t) => + (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs + + val (env', denv') = foldl (fn (x, (env', denv')) => + (E.pushCRel env' x k, + D.enter denv')) (env, denv) xs + + val (xcs, (used, env, gs)) = + ListUtil.foldlMap + (fn ((x, to), (used, env, gs)) => + let + val (to, t, gs') = case to of + NONE => (NONE, t, gs) + | SOME t' => + let + val (t', tk, gs') = + elabCon (env', denv') t' + in + checkKind env' t' tk k; + (SOME t', + (L'.TFun (t', t), loc), + gs' @ gs) + end + val t = foldl (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) + t xs + + val (env, n') = E.pushENamed env x t + in + if SS.member (used, x) then + strError env (DuplicateConstructor (x, loc)) + else + (); + ((x, n', to), (SS.add (used, x), env, gs')) + end) + (SS.empty, env, []) xcs + in + ((x, n, xs, xcs), E.pushDatatype env n xs xcs) + end) + env dts + in + ([(L'.SgiDatatype dts, loc)], (env, denv, gs)) + end + + | L.SgiDatatypeImp (_, [], _) => raise Fail "Empty SgiDatatypeImp" + + | L.SgiDatatypeImp (x, m1 :: ms, s) => + (case E.lookupStr env m1 of + NONE => (strError env (UnboundStr (loc, m1)); + ([], (env, denv, gs))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case hnormCon env (L'.CModProj (n, ms, s), loc) of + (L'.CModProj (n, ms, s), _) => + (case E.projectDatatype env {sgn = sgn, str = str, field = s} of + NONE => (conError env (UnboundDatatype (loc, s)); + ([], (env, denv, []))) + | SOME (xs, xncs) => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + + val t = (L'.CModProj (n, ms, s), loc) + val (env, n') = E.pushCNamed env x k' (SOME t) + val env = E.pushDatatype env n' xs xncs + + val t = (L'.CNamed n', loc) + val env = foldl (fn ((x, n, to), env) => + let + val t = case to of + NONE => t + | SOME t' => (L'.TFun (t', t), loc) + + val t = foldr (fn (x, t) => + (L'.TCFun (L'.Implicit, x, k, t), loc)) + t xs + in + E.pushENamedAs env x n t + end) env xncs + in + ([(L'.SgiDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, [])) + end) + | _ => (strError env (NotDatatype loc); + ([], (env, denv, []))) + end) + + | L.SgiVal (x, c) => + let + val (c', ck, gs') = elabCon (env, denv) c + + val old = c' + val c' = normClassConstraint env c' + val (env', n) = E.pushENamed env x c' + in + (unifyKinds env ck ktype + handle KUnify arg => strError env (NotType (loc, ck, arg))); + + ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) + end + + | L.SgiTable (x, c, pe, ce) => + let + val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) + + val (c', ck, gs') = elabCon (env, denv) c + val pkey = cunif env (loc, cstK) + val visible = cunif env (loc, cstK) + + val x' = x ^ "_hidden_constraints" + val (env', hidden_n) = E.pushCNamed env x' cstK NONE + val hidden = (L'.CNamed hidden_n, loc) + + val uniques = (L'.CConcat (visible, hidden), loc) + + val ct = tableOf () + 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 gs'' = List.mapPartial (fn Disjoint x => SOME x + | _ => NONE) gs'' + + val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc) + val pst = (L'.CApp (pst, c'), loc) + val pst = (L'.CApp (pst, pkey), loc) + + val (ce', cet, gs''') = elabExp (env', denv) ce + val gs''' = List.mapPartial (fn Disjoint x => SOME x + | _ => NONE) gs''' + + val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) + val cst = (L'.CApp (cst, c'), loc) + val cst = (L'.CApp (cst, visible), loc) + + val (env', n) = E.pushENamed env' x ct + in + checkKind env c' ck (L'.KRecord (L'.KType, loc), loc); + checkCon env' pe' pet pst; + checkCon env' ce' cet cst; + + ([(L'.SgiConAbs (x', hidden_n, cstK), loc), + (L'.SgiConstraint ((L'.CConcat (pkey, visible), loc), hidden), loc), + (L'.SgiVal (x, n, ct), loc)], (env', denv, gs''' @ gs'' @ gs' @ gs)) + end + + | L.SgiStr (x, sgn) => + let + val (sgn', gs') = elabSgn (env, denv) sgn + val (env', n) = E.pushStrNamed env x sgn' + val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} + in + ([(L'.SgiStr (L'.Import, x, n, sgn'), loc)], (env', denv', gs' @ gs)) + end + + | L.SgiSgn (x, sgn) => + let + val (sgn', gs') = elabSgn (env, denv) sgn + val (env', n) = E.pushSgnNamed env x sgn' + in + ([(L'.SgiSgn (x, n, sgn'), loc)], (env', denv, gs' @ gs)) + end + + | L.SgiInclude sgn => + let + val (sgn', gs') = elabSgn (env, denv) sgn + in + case #1 (hnormSgn env sgn') of + L'.SgnConst sgis => + (sgis, (foldl (fn (sgi, env) => E.sgiBinds env sgi) env sgis, denv, gs' @ gs)) + | _ => (sgnError env (NotIncludable sgn'); + ([], (env, denv, []))) + end + + | L.SgiConstraint (c1, c2) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + + val denv = D.assert env denv (c1', c2') + in + checkKind env c1' k1 (L'.KRecord (kunif env loc), loc); + checkKind env c2' k2 (L'.KRecord (kunif env loc), loc); + + ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2)) + end + + | L.SgiClassAbs (x, k) => + let + val k = elabKind env k + val (env, n) = E.pushCNamed env x k NONE + val env = E.pushClass env n + in + ([(L'.SgiClassAbs (x, n, k), loc)], (env, denv, [])) + end + + | L.SgiClass (x, k, c) => + let + val k = elabKind env k + val (c', ck, gs) = elabCon (env, denv) c + val (env, n) = E.pushCNamed env x k (SOME c') + val env = E.pushClass env n + in + checkKind env c' ck k; + ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) + end) + +and elabSgn (env, denv) (sgn, loc) = + case sgn of + L.SgnConst sgis => + let + val (sgis', (_, _, gs)) = ListUtil.foldlMapConcat elabSgn_item (env, denv, []) sgis + + val _ = foldl (fn ((sgi, loc), (cons, vals, sgns, strs)) => + case sgi of + L'.SgiConAbs (x, _, _) => + (if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiCon (x, _, _, _) => + (if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiDatatype dts => + let + val (cons, vals) = + let + fun doOne ((x, _, _, xncs), (cons, vals)) = + let + val vals = foldl (fn ((x, _, _), vals) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + SS.add (vals, x))) + vals xncs + in + if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals) + end + in + foldl doOne (cons, vals) dts + end + in + (cons, vals, sgns, strs) + end + | L'.SgiDatatypeImp (x, _, _, _, _, _, _) => + (if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiVal (x, _, _) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + (cons, SS.add (vals, x), sgns, strs)) + | L'.SgiSgn (x, _, _) => + (if SS.member (sgns, x) then + sgnError env (DuplicateSgn (loc, x)) + else + (); + (cons, vals, SS.add (sgns, x), strs)) + | L'.SgiStr (_, x, _, _) => + (if SS.member (strs, x) then + sgnError env (DuplicateStr (loc, x)) + else + (); + (cons, vals, sgns, SS.add (strs, x))) + | L'.SgiConstraint _ => (cons, vals, sgns, strs) + | L'.SgiClassAbs (x, _, _) => + (if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiClass (x, _, _, _) => + (if SS.member (cons, x) then + sgnError env (DuplicateCon (loc, x)) + else + (); + (SS.add (cons, x), vals, sgns, strs))) + (SS.empty, SS.empty, SS.empty, SS.empty) sgis' + in + ((L'.SgnConst sgis', loc), gs) + end + | L.SgnVar x => + (case E.lookupSgn env x of + NONE => + (sgnError env (UnboundSgn (loc, x)); + ((L'.SgnError, loc), [])) + | SOME (n, sgis) => ((L'.SgnVar n, loc), [])) + | L.SgnFun (m, dom, ran) => + let + val (dom', gs1) = elabSgn (env, denv) dom + val (env', n) = E.pushStrNamed env m dom' + val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []} + val (ran', gs2) = elabSgn (env', denv') ran + in + ((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2) + end + | L.SgnWhere (sgn, ms, x, c) => + let + val (sgn', ds1) = elabSgn (env, denv) sgn + val (c', ck, ds2) = elabCon (env, denv) c + + fun checkPath (ms, sgn') = + case #1 (hnormSgn env sgn') of + L'.SgnConst sgis => + List.exists (fn (L'.SgiConAbs (x', _, k), _) => + List.null ms andalso x' = x andalso + (unifyKinds env k ck + handle KUnify x => sgnError env (WhereWrongKind x); + true) + | (L'.SgiStr (_, x', _, sgn''), _) => + (case ms of + [] => false + | m :: ms' => + m = x' andalso + checkPath (ms', sgn'')) + | _ => false) sgis + | _ => false + in + if checkPath (ms, sgn') then + ((L'.SgnWhere (sgn', ms, x, c'), loc), ds1 @ ds2) + else + (sgnError env (UnWhereable (sgn', x)); + (sgnerror, [])) + end + | L.SgnProj (m, ms, x) => + (case E.lookupStr env m of + NONE => (strError env (UnboundStr (loc, m)); + (sgnerror, [])) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (strError env (UnboundStr (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectSgn env {sgn = sgn, str = str, field = x} of + NONE => (sgnError env (UnboundSgn (loc, x)); + (sgnerror, [])) + | SOME _ => ((L'.SgnProj (n, ms, x), loc), []) + end) + + +and selfify env {str, strs, sgn} = + case #1 (hnormSgn env sgn) of + L'.SgnError => sgn + | L'.SgnVar _ => sgn + + | L'.SgnConst sgis => + (L'.SgnConst (#1 (ListUtil.foldlMapConcat + (fn (sgi, env) => + (case sgi of (L'.SgiConAbs (x, n, k), loc) => + [(L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + | (L'.SgiDatatype dts, loc) => + map (fn (x, n, xs, xncs) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts + | (L'.SgiClassAbs (x, n, k), loc) => + [(L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + | (L'.SgiStr (im, x, n, sgn), loc) => + [(L'.SgiStr (im, x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc)] + | x => [x], + E.sgiBinds env sgi)) env sgis)), #2 sgn) + | L'.SgnFun _ => sgn + | L'.SgnWhere _ => sgn + | L'.SgnProj (m, ms, x) => + case E.projectSgn env {str = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn)) + (L'.StrVar m, #2 sgn) ms, + sgn = #2 (E.lookupStrNamed env m), + field = x} of + NONE => raise Fail "Elaborate.selfify: projectSgn returns NONE" + | SOME sgn => selfify env {str = str, strs = strs, sgn = sgn} + +and selfifyAt env {str, sgn} = + let + fun self (str, _) = + case str of + L'.StrVar x => SOME (x, []) + | L'.StrProj (str, x) => + (case self str of + NONE => NONE + | SOME (m, ms) => SOME (m, ms @ [x])) + | _ => NONE + in + case self str of + NONE => sgn + | SOME (str, strs) => selfify env {sgn = sgn, str = str, strs = strs} + end + +and dopen env {str, strs, sgn} = + let + fun isVisible x = x <> "" andalso String.sub (x, 0) <> #"?" + + val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn)) + (L'.StrVar str, #2 sgn) strs + in + case #1 (hnormSgn env sgn) of + L'.SgnConst sgis => + ListUtil.foldlMapConcat + (fn ((sgi, loc), env') => + let + val d = + case sgi of + L'.SgiConAbs (x, n, k) => + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] + | L'.SgiCon (x, n, k, c) => + if isVisible x then + [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)] + else + [] + | L'.SgiDatatype dts => + List.mapPartial (fn (x, n, xs, xncs) => if isVisible x then + SOME (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc) + else + NONE) dts + | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => + if isVisible x then + [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)] + else + [] + | L'.SgiVal (x, n, t) => + if isVisible x then + [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)] + else + [] + | L'.SgiStr (_, x, n, sgn) => + if isVisible x then + [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)] + else + [] + | L'.SgiSgn (x, n, sgn) => + if isVisible x then + [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)] + else + [] + | L'.SgiConstraint (c1, c2) => + [(L'.DConstraint (c1, c2), loc)] + | L'.SgiClassAbs (x, n, k) => + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] + | L'.SgiClass (x, n, k, _) => + if isVisible x then + let + val c = (L'.CModProj (str, strs, x), loc) + in + [(L'.DCon (x, n, k, c), loc)] + end + else + [] + in + (d, foldl (fn (d, env') => E.declBinds env' d) env' d) + end) + env sgis + | _ => (strError env (UnOpenable sgn); + ([], env)) + end + +and sgiOfDecl (d, loc) = + case d of + L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)] + | L'.DDatatype x => [(L'.SgiDatatype x, loc)] + | L'.DDatatypeImp x => [(L'.SgiDatatypeImp x, loc)] + | L'.DVal (x, n, t, _) => [(L'.SgiVal (x, n, t), loc)] + | L'.DValRec vis => map (fn (x, n, t, _) => (L'.SgiVal (x, n, t), loc)) vis + | L'.DSgn (x, n, sgn) => [(L'.SgiSgn (x, n, sgn), loc)] + | L'.DStr (x, n, sgn, _) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] + | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (L'.Import, x, n, sgn), loc)] + | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] + | L'.DExport _ => [] + | L'.DTable (tn, x, n, c, _, pc, _, cc) => + [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), + (L'.CConcat (pc, cc), loc)), loc)), loc)] + | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] + | L'.DView (tn, x, n, _, c) => + [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)] + | L'.DDatabase _ => [] + | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] + | L'.DTask _ => [] + | L'.DPolicy _ => [] + | L'.DOnError _ => [] + | L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)] + +and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = + ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), + ("sgn2", p_sgn env sgn2)];*) + case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of + (L'.SgnError, _) => () + | (_, L'.SgnError) => () + + | (L'.SgnConst sgis1, L'.SgnConst sgis2) => + let + (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), + ("sgn2", p_sgn env sgn2), + ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), + ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) + + fun cpart n = IM.find (!counterparts, n) + fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1) + fun uncparts n2 = (counterparts := #1 (IM.remove (!counterparts, n2))) + handle NotFound => () + + val sub2 = U.Con.map {kind = fn k => k, + con = fn c => + case c of + L'.CNamed n2 => + (case cpart n2 of + NONE => c + | SOME n1 => L'.CNamed n1) + | _ => c} + + fun folder (sgi2All as (sgi, loc), env) = + let + (*val () = prefaces "folder" [("sgi2", p_sgn_item env sgi2All)]*) + + fun seek' f p = + let + fun seek env ls = + case ls of + [] => f env + | h :: t => + case p (env, h) of + NONE => + let + val env = case #1 h of + L'.SgiCon (x, n, k, c) => + if E.checkENamed env n then + env + else + (uncparts n; + E.pushCNamedAs env x n k (SOME c)) + | L'.SgiConAbs (x, n, k) => + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k NONE + | _ => env + in + seek (E.sgiBinds env h) t + end + | SOME envs => envs + in + seek env sgis1 + end + + val seek = seek' (fn env => (sgnError env (UnmatchedSgi (strLoc, sgi2All)); + env)) + in + case sgi of + L'.SgiConAbs (x, n2, k2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + let + fun found (x', n1, k1, co1) = + if x = x' then + let + val () = unifyKinds env k1 k2 + handle KUnify (k1, k2, env', err) => + sgnError env (SgiWrongKind (loc, sgi1All, k1, + sgi2All, k2, env', err)) + val env = E.pushCNamedAs env x n1 k1 co1 + in + SOME (if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2)))) + end + else + NONE + in + case sgi1 of + L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, SOME c1) + | L'.SgiDatatype dts => + let + val k = (L'.KType, loc) + + fun search dts = + case dts of + [] => NONE + | (x', n1, xs, _) :: dts => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + in + case found (x', n1, k', NONE) of + NONE => search dts + | x => x + end + in + search dts + end + | L'.SgiDatatypeImp (x', n1, m1, ms, s, xs, _) => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + in + found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc)) + end + | L'.SgiClassAbs (x', n1, k) => found (x', n1, k, NONE) + | L'.SgiClass (x', n1, k, c) => found (x', n1, k, SOME c) + | _ => NONE + end) + + | L'.SgiCon (x, n2, k2, c2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + let + fun found (x', n1, k1, c1) = + if x = x' then + let + val c2 = sub2 c2 + + fun good () = + let + val env = E.pushCNamedAs env x n2 k2 (SOME c2) + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x n1 k1 (SOME c1)) + in + SOME env + end + in + (unifyCons env loc c1 c2; + good ()) + handle CUnify (c1, c2, env', err) => + (sgnError env (SgiWrongCon (loc, sgi1All, c1, + sgi2All, c2, env', err)); + good ()) + end + else + NONE + in + case sgi1 of + L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) + | L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) + | _ => NONE + end) + + | L'.SgiDatatype dts2 => + let + fun found' (sgi1All as (_, loc), (x1, n1, xs1, xncs1), (x2, n2, xs2, xncs2), env) = + if x1 <> x2 then + NONE + else + let + fun mismatched ue = + (sgnError env (SgiMismatchedDatatypes (loc, sgi1All, sgi2All, ue)); + SOME env) + + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs1 + + fun good () = + let + val env = E.sgiBinds env sgi1All + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' + (SOME (L'.CNamed n1, loc))) + in + 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))) + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 + fun xncBad ((x1, _, t1), (x2, _, t2)) = + String.compare (x1, x2) <> EQUAL + orelse case (t1, t2) of + (NONE, NONE) => false + | (SOME t1, SOME t2) => + (unifyCons env loc t1 (sub2 t2); false) + | _ => true + in + (if xs1 <> xs2 + orelse length xncs1 <> length xncs2 + orelse ListPair.exists xncBad (xncs1, xncs2) then + mismatched NONE + else + good ()) + handle CUnify ue => mismatched (SOME ue) + end + in + seek' + (fn _ => + let + fun seekOne (dt2, env) = + seek (fn (env, sgi1All as (sgi1, _)) => + case sgi1 of + L'.SgiDatatypeImp (x', n1, _, _, _, xs, xncs1) => + found' (sgi1All, (x', n1, xs, xncs1), dt2, env) + | _ => NONE) + + fun seekAll (dts, env) = + case dts of + [] => env + | dt :: dts => seekAll (dts, seekOne (dt, env)) + in + seekAll (dts2, env) + end) + (fn (env, sgi1All as (sgi1, _)) => + let + fun found dts1 = + let + fun iter (dts1, dts2, env) = + case (dts1, dts2) of + ([], []) => SOME env + | (dt1 :: dts1, dt2 :: dts2) => + (case found' (sgi1All, dt1, dt2, env) of + NONE => NONE + | SOME env => iter (dts1, dts2, env)) + | _ => NONE + in + iter (dts1, dts2, env) + end + in + case sgi1 of + L'.SgiDatatype dts1 => found dts1 + | _ => NONE + end) + end + + | L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) => + seek (fn (env, sgi1All as (sgi1, loc)) => + case sgi1 of + L'.SgiDatatypeImp (x', n1, m11, ms1, s1, _, _) => + if x = x' then + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val t1 = (L'.CModProj (m11, ms1, s1), loc) + val t2 = (L'.CModProj (m12, ms2, s2), loc) + + fun good () = + let + val env = E.pushCNamedAs env x n1 k' (SOME t1) + val env = E.pushCNamedAs env x n2 k' (SOME t2) + in + cparts (n2, n1); + SOME env + end + in + (unifyCons env loc t1 t2; + good ()) + handle CUnify (c1, c2, env', err) => + (sgnError env (SgiWrongCon (loc, sgi1All, c1, sgi2All, c2, env', err)); + good ()) + end + else + NONE + + | _ => NONE) + + | L'.SgiVal (x, n2, c2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + case sgi1 of + L'.SgiVal (x', n1, c1) => + if x = x' then + ((*prefaces "val" [("x", PD.string x), + ("n1", PD.string (Int.toString n1)), + ("c1", p_con env c1), + ("c2", p_con env c2), + ("c2'", p_con env (sub2 c2))];*) + unifyCons env loc c1 (sub2 c2); + SOME env) + handle CUnify (c1, c2, env', err) => + (sgnError env (SgiWrongCon (loc, sgi1All, c1, sgi2All, c2, env', err)); + SOME env) + else + NONE + | _ => NONE) + + | L'.SgiStr (_, x, n2, sgn2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + case sgi1 of + L'.SgiStr (_, x', n1, sgn1) => + if x = x' then + let + (* Don't forget to save & restore the + * counterparts map around recursive calls! + * Otherwise, all sorts of mayhem may result. *) + val saved = !counterparts + val () = subSgn' counterparts env loc sgn1 sgn2 + val () = counterparts := saved + val env = E.pushStrNamedAs env x n1 sgn1 + val env = if n1 = n2 then + env + else + E.pushStrNamedAs env x n2 + (selfifyAt env {str = (L'.StrVar n1, #2 sgn2), + sgn = sgn2}) + in + SOME env + end + else + NONE + | _ => NONE) + + | L'.SgiSgn (x, n2, sgn2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + case sgi1 of + L'.SgiSgn (x', n1, sgn1) => + if x = x' then + let + val () = subSgn' counterparts env loc sgn1 sgn2 + val () = subSgn' counterparts env loc sgn2 sgn1 + + val env = E.pushSgnNamedAs env x n2 sgn2 + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushSgnNamedAs env x n1 sgn2) + in + SOME env + end + else + NONE + | _ => NONE) + + | L'.SgiConstraint (c2, d2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + case sgi1 of + L'.SgiConstraint (c1, d1) => + (* It's important to do only simple equality checking here, + * with no unification, because constraints are unnamed. + * It's too easy to pick the wrong pair to unify! *) + if consEqSimple env (c1, c2) + andalso consEqSimple env (d1, d2) then + SOME env + else + NONE + | _ => NONE) + + | L'.SgiClassAbs (x, n2, k2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + let + fun found (x', n1, k1, co) = + if x = x' then + let + val () = unifyKinds env k1 k2 + handle KUnify (k1, k2, env', err) => + sgnError env (SgiWrongKind (loc, sgi1All, k1, + sgi2All, k2, env', err)) + + val env = E.pushCNamedAs env x n1 k1 co + in + SOME (if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2)))) + end + else + NONE + in + case sgi1 of + L'.SgiClassAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiClass (x', n1, k1, c) => found (x', n1, k1, SOME c) + | L'.SgiConAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiCon (x', n1, k1, c) => found (x', n1, k1, SOME c) + | _ => NONE + end) + | L'.SgiClass (x, n2, k2, c2) => + seek (fn (env, sgi1All as (sgi1, loc)) => + let + fun found (x', n1, k1, c1) = + if x = x' then + let + val () = unifyKinds env k1 k2 + handle KUnify (k1, k2, env', err) => + sgnError env (SgiWrongKind (loc, sgi1All, k1, + sgi2All, k2, env', err)) + + val c2 = sub2 c2 + + fun good () = + let + val env = E.pushCNamedAs env x n2 k2 (SOME c2) + val env = if n1 = n2 then + env + else + (cparts (n2, n1); + E.pushCNamedAs env x n1 k2 (SOME c1)) + in + SOME env + end + in + (unifyCons env loc c1 c2; + good ()) + handle CUnify (c1, c2, env', err) => + (sgnError env (SgiWrongCon (loc, sgi1All, c1, + sgi2All, c2, env', err)); + good ()) + end + else + NONE + in + case sgi1 of + L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) + | L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) + | _ => NONE + end) + end + in + ignore (foldl folder env sgis2) + end + + | (L'.SgnFun (m1, n1, dom1, ran1), L'.SgnFun (m2, n2, dom2, ran2)) => + let + val ran2 = + if n1 = n2 then + ran2 + else + subStrInSgn (n2, n1) ran2 + in + subSgn' counterparts env strLoc dom2 dom1; + subSgn' counterparts (E.pushStrNamedAs env m1 n1 dom2) strLoc ran1 ran2 + end + + | _ => sgnError env (SgnWrongForm (strLoc, sgn1, sgn2))) + +and subSgn env x y z = subSgn' (ref IM.empty) env x y z + handle e as E.UnboundNamed _ => if ErrorMsg.anyErrors () then () else raise e + +and positive self = + let + open L + + fun none (c, _) = + case c of + CAnnot (c, _) => none c + + | TFun (c1, c2) => none c1 andalso none c2 + | TCFun (_, _, _, c) => none c + | TRecord c => none c + + | CVar ([], x) => x <> self + | CVar _ => true + | CApp (c1, c2) => none c1 andalso none c2 + | CAbs _ => false + | TDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 + + | CKAbs _ => false + | TKFun _ => false + + | CName _ => true + + | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs + | CConcat (c1, c2) => none c1 andalso none c2 + | CMap => true + + | CUnit => true + + | CTuple cs => List.all none cs + | CProj (c, _) => none c + + | CWild _ => false + + fun pos (c, _) = + case c of + CAnnot (c, _) => pos c + + | TFun (c1, c2) => none c1 andalso pos c2 + | TCFun (_, _, _, c) => pos c + | TRecord c => pos c + + | CVar _ => true + | CApp (c1, c2) => pos c1 andalso none c2 + | CAbs _ => false + | TDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3 + + | CKAbs _ => false + | TKFun _ => false + + | CName _ => true + + | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs + | CConcat (c1, c2) => pos c1 andalso pos c2 + | CMap => true + + | CUnit => true + + | CTuple cs => List.all pos cs + | CProj (c, _) => pos c + + | CWild _ => false + in + pos + end + +and wildifyStr env (str, sgn) = + case #1 (hnormSgn env sgn) of + L'.SgnConst sgis => + (case #1 str of + L.StrConst ds => + let + fun cname d = + case d of + L'.SgiCon (x, _, _, _) => SOME x + | L'.SgiConAbs (x, _, _) => SOME x + | L'.SgiClass (x, _, _, _) => SOME x + | L'.SgiClassAbs (x, _, _) => SOME x + | _ => NONE + + fun dname (d, _) = + case d of + L.DCon (x, _, _) => SOME x + | _ => NONE + + fun decompileKind (k, loc) = + case k of + L'.KType => SOME (L.KType, loc) + | L'.KArrow (k1, k2) => + (case (decompileKind k1, decompileKind k2) of + (SOME k1, SOME k2) => SOME (L.KArrow (k1, k2), loc) + | _ => NONE) + | L'.KName => SOME (L.KName, loc) + | L'.KRecord k => + (case decompileKind k of + SOME k => SOME (L.KRecord k, loc) + | _ => NONE) + | L'.KUnit => SOME (L.KUnit, loc) + | L'.KTuple ks => + let + val ks' = List.mapPartial decompileKind ks + in + if length ks' = length ks then + SOME (L.KTuple ks', loc) + else + NONE + end + + | L'.KError => NONE + | L'.KUnif (_, _, ref (L'.KKnown k)) => decompileKind k + | L'.KUnif _ => NONE + | L'.KTupleUnif (_, _, ref (L'.KKnown k)) => decompileKind k + | L'.KTupleUnif _ => NONE + + | L'.KRel _ => NONE + | L'.KFun _ => NONE + + fun maybeHnorm env c = + hnormCon env c + handle E.UnboundNamed _ => c + + fun decompileCon env c = + case decompileCon' env c of + SOME v => SOME v + | NONE => decompileCon' env (maybeHnorm env c) + + and decompileCon' env (c as (_, loc)) = + case #1 c of + L'.CRel i => + let + val (s, _) = E.lookupCRel env i + in + SOME (L.CVar ([], s), loc) + end + | L'.CNamed i => + let + val (s, _, _) = E.lookupCNamed env i + in + SOME (L.CVar ([], s), loc) + end + | L'.CModProj (m1, ms, x) => + let + val (s, _) = E.lookupStrNamed env m1 + in + SOME (L.CVar (s :: ms, x), loc) + end + | L'.CName s => SOME (L.CName s, loc) + | L'.CRecord (k, xcs) => + let + fun fields xcs = + case xcs of + [] => SOME [] + | (x, t) :: xcs => + case (decompileCon env x, decompileCon env t, fields xcs) of + (SOME x, SOME t, SOME xcs) => SOME ((x, t) :: xcs) + | _ => NONE + + val c' = Option.map (fn xcs => (L.CRecord xcs, loc)) + (fields xcs) + in + Option.map (fn c' => + case decompileKind k of + NONE => c' + | SOME k' => (L.CAnnot (c', (L.KRecord k', loc)), loc)) c' + end + | L'.CConcat (c1, c2) => + (case (decompileCon env c1, decompileCon env c2) of + (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc) + | _ => NONE) + | L'.CUnit => SOME (L.CUnit, loc) + | L'.CUnif (nl, _, _, _, ref (L'.Known c)) => decompileCon env (E.mliftConInCon nl c) + + | L'.CApp (f, x) => + (case (decompileCon env f, decompileCon env x) of + (SOME f, SOME x) => SOME (L.CApp (f, x), loc) + | _ => NONE) + + | L'.CTuple cs => + let + val cs' = foldr (fn (c, cs') => + case cs' of + NONE => NONE + | SOME cs' => + case decompileCon env c of + NONE => NONE + | SOME c' => SOME (c' :: cs')) + (SOME []) cs + in + case cs' of + NONE => NONE + | SOME cs' => SOME (L.CTuple cs', loc) + end + + | L'.CMap _ => SOME (L.CMap, loc) + | L'.TRecord c => + (case decompileCon env c of + NONE => NONE + | SOME c' => SOME (L.TRecord c', loc)) + + | c => ((*Print.preface ("WTF?", p_con env (c, loc));*) NONE) + + fun isClassOrFolder' env (c : L'.con) = + case #1 c of + L'.CAbs (x, k, c) => + let + val env = E.pushCRel env x k + + fun toHead (c : L'.con) = + case #1 c of + L'.CApp (c, _) => toHead c + | _ => isClassOrFolder env c + in + toHead (hnormCon env c) + end + | _ => isClassOrFolder env c + + fun buildNeeded env sgis = + #1 (foldl (fn ((sgi, loc), (nd, env')) => + (case sgi of + L'.SgiCon (x, _, k, _) => naddCon (nd, x, k) + | L'.SgiConAbs (x, _, k) => naddCon (nd, x, k) + | L'.SgiConstraint cs => naddConstraint (nd, (env', cs, loc)) + | L'.SgiVal (x, _, t) => + let + fun should t = + let + val t = normClassConstraint env' t + + fun shouldR c = + case hnormCon env' c of + (L'.CApp (f, _), _) => + (case hnormCon env' f of + (L'.CApp (f, cl), loc) => + (case hnormCon env' f of + (L'.CMap _, _) => isClassOrFolder' env' cl + | _ => false) + | _ => false) + | (L'.CConcat (c1, c2), _) => + shouldR c1 orelse shouldR c2 + | c => false + in + case #1 t of + L'.CApp (f, _) => isClassOrFolder env' f + | L'.TRecord t => shouldR t + | _ => false + end + in + if should t then + naddVal (nd, x) + else + nd + end + | L'.SgiStr (_, x, _, s) => + (case #1 (hnormSgn env' s) of + L'.SgnConst sgis' => naddMod (nd, x, (env', buildNeeded env' sgis')) + | _ => nd) + | _ => nd, + E.sgiBinds env' (sgi, loc))) + (nempty, env) sgis) + + val nd = buildNeeded env sgis + + fun removeUsed (nd, ds) = + foldl (fn ((d, _), nd) => + case d of + L.DCon (x, _, _) => ndelCon (nd, x) + | L.DVal (p, _) => + foldl (fn (x, nd) => ndelVal (nd, x)) nd (patVarsOf p) + | L.DOpen _ => nempty + | L.DStr (x, _, _, (L.StrConst ds', _), _) => + (case SM.find (nmods nd, x) of + NONE => nd + | SOME (env, nd') => naddMod (nd, x, (env, removeUsed (nd', ds')))) + | _ => nd) + nd ds + + val nd = removeUsed (nd, ds) + + (* Among the declarations present explicitly in the program, find the last constructor or constraint declaration. + * The new constructor/constraint declarations that we add may safely be put after that point. *) + fun findLast (ds, acc) = + case ds of + [] => ([], acc) + | (d : L.decl) :: ds' => + let + val isCony = case #1 d of + L.DCon _ => true + | L.DDatatype _ => true + | L.DDatatypeImp _ => true + | L.DStr _ => true + | L.DConstraint _ => true + | _ => false + in + if isCony then + (ds, acc) + else + findLast (ds', d :: acc) + end + + val (dPrefix, dSuffix) = findLast (rev ds, []) + + fun extend (env, nd, ds) = + let + val ds' = List.mapPartial (fn (env', (c1, c2), loc) => + case (decompileCon env' c1, decompileCon env' c2) of + (SOME c1, SOME c2) => + SOME (L.DConstraint (c1, c2), loc) + | _ => NONE) (nconstraints nd) + + val ds' = + case SS.listItems (nvals nd) of + [] => ds' + | xs => + let + val ewild = (L.EWild, #2 str) + val ds'' = map (fn x => (L.DVal ((L.PVar x, #2 str), ewild), #2 str)) xs + in + ds'' @ ds' + end + + val ds' = + case ncons nd of + [] => ds' + | xs => + map (fn (x, k) => + let + val k = + case decompileKind k of + NONE => (L.KWild, #2 str) + | SOME k => k + + val cwild = (L.CWild k, #2 str) + in + (L.DCon (x, NONE, cwild), #2 str) + end) xs @ ds' + + val ds = ds @ ds' + in + map (fn d as (L.DStr (x, s, tm, (L.StrConst ds', loc'), r), loc) => + (case SM.find (nmods nd, x) of + NONE => d + | SOME (env, nd') => + (L.DStr (x, s, tm, (L.StrConst (extend (env, nd', ds')), loc'), r), loc)) + | d => d) ds + end + in + (L.StrConst (extend (env, nd, rev dPrefix) @ dSuffix), #2 str) + end + | _ => str) + | _ => str + +and elabDecl (dAll as (d, loc), (env, denv, gs)) = + let + (*val () = preface ("elabDecl", SourcePrint.p_decl dAll)*) + (*val befor = Time.now ()*) + + val r = + case d of + L.DCon (x, ko, c) => + let + val k' = case ko of + NONE => kunif env loc + | SOME k => elabKind env k + + val (c', ck, gs') = elabCon (env, denv) c + val (env', n) = E.pushCNamed env x k' (SOME c') + in + checkKind env c' ck k'; + + ([(L'.DCon (x, n, k', c'), loc)], (env', denv, enD gs' @ gs)) + end + | L.DDatatype dts => + let + val k = (L'.KType, loc) + + val (dts, env) = ListUtil.foldlMap + (fn ((x, xs, xcs), env) => + let + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val (env, n) = E.pushCNamed env x k' NONE + in + ((x, n, xs, xcs), env) + end) + env dts + + val (dts, (env, gs')) = ListUtil.foldlMap + (fn ((x, n, xs, xcs), (env, gs')) => + let + val t = (L'.CNamed n, loc) + val nxs = length xs - 1 + val t = ListUtil.foldli + (fn (i, _, t) => + (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs + + val (env', denv') = foldl (fn (x, (env', denv')) => + (E.pushCRel env' x k, + D.enter denv')) (env, denv) xs + + val (xcs, (used, env, gs')) = + ListUtil.foldlMap + (fn ((x, to), (used, env, gs)) => + let + val (to, t, gs') = case to of + NONE => (NONE, t, gs) + | SOME t' => + let + val (t', tk, gs') = elabCon (env', denv') t' + in + checkKind env' t' tk k; + (SOME t', (L'.TFun (t', t), loc), enD gs' @ gs) + end + val t = foldr (fn (x, t) => (L'.TCFun (L'.Implicit, x, k, t), loc)) t xs + + val (env, n') = E.pushENamed env x t + in + if SS.member (used, x) then + strError env (DuplicateConstructor (x, loc)) + else + (); + ((x, n', to), (SS.add (used, x), env, gs')) + end) + (SS.empty, env, gs') xcs + in + ((x, n, xs, xcs), (E.pushDatatype env n xs xcs, gs')) + end) + (env, []) dts + in + ([(L'.DDatatype dts, loc)], (env, denv, gs' @ gs)) + end + + | L.DDatatypeImp (_, [], _) => raise Fail "Empty DDatatypeImp" + + | L.DDatatypeImp (x, m1 :: ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, gs))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case hnormCon env (L'.CModProj (n, ms, s), loc) of + (L'.CModProj (n, ms, s), _) => + (case E.projectDatatype env {sgn = sgn, str = str, field = s} of + NONE => (conError env (UnboundDatatype (loc, s)); + ([], (env, denv, gs))) + | SOME (xs, xncs) => + let + val k = (L'.KType, loc) + val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs + val t = (L'.CModProj (n, ms, s), loc) + val (env, n') = E.pushCNamed env x k' (SOME t) + val env = E.pushDatatype env n' xs xncs + + val t = (L'.CNamed n', loc) + val nxs = length xs + val t = ListUtil.foldli (fn (i, _, t) => + (L'.CApp (t, (L'.CRel (nxs - 1 - i), loc)), loc)) + t xs + val env = foldl (fn ((x, n, to), env) => + let + val t = case to of + NONE => t + | SOME t' => (L'.TFun (t', t), loc) + + val t = foldr (fn (x, t) => + (L'.TCFun (L'.Implicit, x, k, t), loc)) + t xs + in + E.pushENamedAs env x n t + end) env xncs + in + ([(L'.DDatatypeImp (x, n', n, ms, s, xs, xncs), loc)], (env, denv, gs)) + end) + | _ => (strError env (NotDatatype loc); + ([], (env, denv, []))) + end) + + | L.DVal (p, e) => + let + val ((p', pt), (env', bound)) = elabPat (p, (env, SS.empty)) + + val (e', et, gs1) = elabExp (env, denv) e + + val c' = normClassConstraint env et + + fun singleVar (p : L.pat) = + case #1 p of + L.PVar x => SOME x + | L.PAnnot (p', _) => singleVar p' + | _ => NONE + in + unifyCons env loc et pt; + + (case exhaustive (env, et, [p'], loc) of + NONE => () + | SOME p => if !mayDelay then + delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives + else + expError env (Inexhaustive (loc, p))); + + case singleVar p of + SOME x => + let + val (env', n) = E.pushENamed env x et + in + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, gs1 @ gs)) + end + | NONE => + let + val (env', n) = E.pushENamed env "$tmp" et + val vars = SS.listItems bound + val (decls, env') = + ListUtil.foldlMap (fn (x, env') => + let + val e = (L.ECase ((L.EVar ([], "$tmp", L.Infer), loc), + [(p, (L.EVar ([], x, L.Infer), loc))]), loc) + val (e', t, _) = elabExp (env', denv) e + val (env', n) = E.pushENamed env' x t + in + ((L'.DVal (x, n, t, e'), loc), + env') + end) env' vars + in + ((L'.DVal ("$tmp", n, c', e'), loc) :: decls, + (env', denv, gs1 @ gs)) + end + end + | L.DValRec vis => + let + fun allowable (e, _) = + case e of + L.EAbs _ => true + | L.ECAbs (_, _, _, e) => allowable e + | L.EKAbs (_, e) => allowable e + | L.EDisjoint (_, _, e) => allowable e + | _ => false + + val (vis, gs) = ListUtil.foldlMap + (fn ((x, co, e), gs) => + let + val (c', _, gs1) = case co of + NONE => (cunif env (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + val c' = normClassConstraint env c' + in + ((x, c', e), enD gs1 @ gs) + end) gs vis + + val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) => + let + val (env, n) = E.pushENamed env x c' + in + ((x, n, c', e), env) + end) env vis + + val (vis, gs) = ListUtil.foldlMap (fn ((x, n, c', e), gs) => + let + val (e', et, gs1) = elabExp (env, denv) e + in + checkCon env e' et c'; + if allowable e then + () + else + expError env (IllegalRec (x, e')); + ((x, n, c', e'), gs1 @ gs) + end) gs vis + + val vis = map (fn (x, n, t, e) => (x, n, normClassConstraint env t, e)) vis + val d = (L'.DValRec vis, loc) + in + ([d], (E.declBinds env d, denv, gs)) + end + + | L.DSgn (x, sgn) => + let + val (sgn', gs') = elabSgn (env, denv) sgn + val (env', n) = E.pushSgnNamed env x sgn' + in + ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs)) + end + + | L.DStr (x, sgno, tmo, str, _) => + (case ModDb.lookup dAll of + SOME d => + let + val () = if !verbose then TextIO.print ("REUSE: " ^ x ^ "\n") else () + val env' = E.declBinds env d + val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} + in + ([d], (env', denv', gs)) + end + | NONE => + let + val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else () + + val () = if x = "Basis" then + raise Fail "Not allowed to redefine structure 'Basis'" + else + () + + val formal = Option.map (elabSgn (env, denv)) sgno + + val (str', sgn', gs') = + case formal of + NONE => + let + val (str', actual, gs') = elabStr (env, denv) str + in + (str', selfifyAt env {str = str', sgn = actual}, gs') + end + | SOME (formal, gs1) => + let + val str = wildifyStr env (str, formal) + val (str', actual, gs2) = elabStr (env, denv) str + in + subSgn env loc (selfifyAt env {str = str', sgn = actual}) formal; + (str', formal, enD gs1 @ gs2) + end + + val (env', n) = E.pushStrNamed env x sgn' + + val denv' = + case #1 str' of + L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []} + | L'.StrApp _ => dopenConstraints (loc, env', denv) {str = x, strs = []} + | _ => denv + + val dNew = (L'.DStr (x, n, sgn', str'), loc) + in + case #1 (hnormSgn env sgn') of + L'.SgnFun _ => + (case #1 str' of + L'.StrFun _ => () + | _ => strError env (FunctorRebind loc)) + | _ => (); + Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + ([dNew], (env', denv', gs' @ gs)) + end) + + | L.DFfiStr (x, sgn, tmo) => + (case ModDb.lookup dAll of + SOME d => + let + val env' = E.declBinds env d + val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []} + in + ([d], (env', denv', [])) + end + | NONE => + let + val (sgn', gs') = elabSgn (env, denv) sgn + + val (env', n) = E.pushStrNamed env x sgn' + + val dNew = (L'.DFfiStr (x, n, sgn'), loc) + in + case #1 sgn' of + L'.SgnConst sgis => + (case List.find (fn (L'.SgiConAbs _, _) => false + | (L'.SgiCon _, _) => false + | (L'.SgiDatatype _, _) => false + | (L'.SgiVal _, _) => false + | _ => true) sgis of + NONE => () + | SOME sgi => (ErrorMsg.errorAt loc "Disallowed signature item for FFI module"; + epreface ("item", p_sgn_item env sgi))) + | _ => raise Fail "FFI signature isn't SgnConst"; + + Option.map (fn tm => ModDb.insert (dNew, tm)) tmo; + ([dNew], (env', denv, enD gs' @ gs)) + end) + + | L.DOpen (m, ms) => + (case E.lookupStr env m of + NONE => (strError env (UnboundStr (loc, m)); + ([], (env, denv, gs))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {str = str, sgn = sgn, field = m} of + NONE => (strError env (UnboundStr (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val sgn = selfifyAt env {str = str, sgn = sgn} + + val (ds, env') = dopen env {str = n, strs = ms, sgn = sgn} + val denv' = dopenConstraints (loc, env', denv) {str = m, strs = ms} + in + (ds, (env', denv', gs)) + end) + + | L.DConstraint (c1, c2) => + let + val (c1', k1, gs1) = elabCon (env, denv) c1 + val (c2', k2, gs2) = elabCon (env, denv) c2 + val gs3 = D.prove env denv (c1', c2', loc) + + val denv' = D.assert env denv (c1', c2') + in + checkKind env c1' k1 (L'.KRecord (kunif env loc), loc); + checkKind env c2' k2 (L'.KRecord (kunif env loc), loc); + + ([(L'.DConstraint (c1', c2'), loc)], (env, denv', enD gs1 @ enD gs2 @ enD gs3 @ gs)) + end + + | L.DOpenConstraints (m, ms) => + let + val denv = dopenConstraints (loc, env, denv) {str = m, strs = ms} + in + ([], (env, denv, gs)) + end + + | L.DExport str => + let + val (str', sgn, gs') = elabStr (env, denv) str + + val sgn = + case #1 (hnormSgn env sgn) of + L'.SgnConst sgis => + let + fun doOne (all as (sgi, _), env) = + (case sgi of + L'.SgiVal (x, n, t) => + let + fun doPage (makeRes, ran) = + case hnormCon env ran of + (L'.CApp (tf, arg), _) => + (case (hnormCon env tf, hnormCon env arg) of + ((L'.CModProj (basis, [], "transaction"), _), + (L'.CApp (tf, arg3), _)) => + (case (basis = !basis_r, + hnormCon env tf, hnormCon env arg3) of + (true, + (L'.CApp (tf, arg2), _), + ((L'.CRecord (_, []), _))) => + (case (hnormCon env tf) of + (L'.CApp (tf, arg1), _) => + (case (hnormCon env tf, + hnormCon env arg1, + hnormCon env arg2) of + (tf, arg1, + (L'.CRecord (_, []), _)) => + let + val t = (L'.CApp (tf, arg1), loc) + val t = (L'.CApp (t, arg2), loc) + val t = (L'.CApp (t, arg3), loc) + val t = (L'.CApp ( + (L'.CModProj + (basis, [], "transaction"), loc), + t), loc) + + fun normArgs t = + case hnormCon env t of + (L'.TFun (dom, ran), loc) => + (L'.TFun (hnormCon env dom, normArgs ran), loc) + | t' => t' + in + (L'.SgiVal (x, n, normArgs (makeRes t)), loc) + end + | _ => all) + | _ => all) + | _ => all) + | _ => all) + | _ => all + in + case hnormCon env t of + (L'.TFun (dom, ran), _) => + (case hnormCon env dom of + (L'.TRecord domR, _) => + doPage (fn t => (L'.TFun ((L'.TRecord domR, + loc), + t), loc), ran) + | _ => all) + | _ => doPage (fn t => t, t) + end + | _ => all, + E.sgiBinds env all) + in + (L'.SgnConst (#1 (ListUtil.foldlMap doOne env sgis)), loc) + end + | _ => sgn + in + ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs)) + end + + | L.DTable (x, c, pe, ce) => + let + val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc) + + val (c', k, gs') = elabCon (env, denv) c + val pkey = cunif env (loc, cstK) + val uniques = cunif env (loc, cstK) + + val ct = tableOf () + val ct = (L'.CApp (ct, c'), loc) + val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc) + + val (env, n) = E.pushENamed env x ct + val (pe', pet, gs'') = elabExp (env, denv) pe + val (ce', cet, gs''') = elabExp (env, denv) ce + + val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc) + val pst = (L'.CApp (pst, c'), loc) + val pst = (L'.CApp (pst, pkey), loc) + + val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc) + val cst = (L'.CApp (cst, c'), loc) + val cst = (L'.CApp (cst, uniques), loc) + in + checkKind env c' k (L'.KRecord (L'.KType, loc), loc); + checkCon env pe' pet pst; + checkCon env ce' cet cst; + ([(L'.DTable (!basis_r, x, n, c', pe', pkey, ce', uniques), loc)], + (env, denv, gs''' @ gs'' @ enD gs' @ gs)) + end + | L.DSequence x => + let + val (env, n) = E.pushENamed env x (sequenceOf ()) + in + ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) + end + | L.DView (x, e) => + let + val (e', t, gs') = elabExp (env, denv) e + + val k = (L'.KRecord (L'.KType, loc), loc) + val fs = cunif env (loc, k) + val ts = cunif env (loc, (L'.KRecord k, loc)) + val tf = (L'.CApp ((L'.CMap (k, k), loc), + (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc) + val ts = (L'.CApp (tf, ts), loc) + + val cv = viewOf () + val cv = (L'.CApp (cv, fs), loc) + val (env', n) = E.pushENamed env x cv + + val ct = queryOf () + val ct = (L'.CApp (ct, (L'.CRecord ((L'.KRecord (L'.KType, loc), loc), []), loc)), loc) + val ct = (L'.CApp (ct, (L'.CRecord ((L'.KRecord (L'.KType, loc), loc), []), loc)), loc) + val ct = (L'.CApp (ct, ts), loc) + val ct = (L'.CApp (ct, fs), loc) + in + checkCon env e' t ct; + ([(L'.DView (!basis_r, x, n, e', fs), loc)], + (env', denv, gs' @ gs)) + end + + | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) + + | L.DCookie (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) + in + checkKind env c' k (L'.KType, loc); + ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end + | L.DStyle x => + let + val (env, n) = E.pushENamed env x (styleOf ()) + in + ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) + end + | L.DTask (e1, e2) => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + val (e2', t2, gs2) = elabExp (env, denv) e2 + + val targ = cunif env (loc, (L'.KType, loc)) + + val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc) + val t1' = (L'.CApp (t1', targ), loc) + + val t2' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), + (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc) + val t2' = (L'.TFun (targ, t2'), loc) + in + checkCon env e1' t1 t1'; + checkCon env e2' t2 t2'; + ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs)) + end + | L.DPolicy e1 => + let + val (e1', t1, gs1) = elabExp (env, denv) e1 + + val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc) + in + checkCon env e1' t1 t1'; + ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs)) + end + + | L.DOnError (m1, ms, s) => + (case E.lookupStr env m1 of + NONE => (expError env (UnboundStrInExp (loc, m1)); + ([], (env, denv, []))) + | SOME (n, sgn) => + let + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => (conError env (UnboundStrInCon (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + + val t = case E.projectVal env {sgn = sgn, str = str, field = s} of + NONE => (expError env (UnboundExp (loc, s)); + cerror) + | SOME t => t + + val page = (L'.CModProj (!basis_r, [], "page"), loc) + val xpage = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc), page), loc) + val func = (L'.TFun ((L'.CModProj (!basis_r, [], "xbody"), loc), xpage), loc) + in + (unifyCons env loc t func + handle CUnify _ => ErrorMsg.error "onError handler has wrong type."); + ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs)) + end) + + | L.DFfi (x, modes, t) => + let + val () = if Settings.getLessSafeFfi () then + () + else + ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory." + + val (t', _, gs1) = elabCon (env, denv) t + val t' = normClassConstraint env t' + val (env', n) = E.pushENamed env x t' + in + ([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs)) + end + + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) + in + (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll), + ("d'", p_list_sep PD.newline (ElabPrint.p_decl env) (#1 r))];*) + r + end + +and elabStr (env, denv) (str, loc) = + case str of + L.StrConst ds => + let + val (ds', (_, _, gs)) = ListUtil.foldlMapConcat elabDecl (env, denv, []) ds + val sgis = ListUtil.mapConcat sgiOfDecl ds' + + val (sgis, _, _, _, _) = + foldr (fn ((sgi, loc), (sgis, cons, vals, sgns, strs)) => + case sgi of + L'.SgiConAbs (x, n, k) => + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + in + ((L'.SgiConAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiCon (x, n, k, c) => + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + in + ((L'.SgiCon (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiDatatype dts => + let + fun doOne ((x, n, xs, xncs), (cons, vals)) = + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + + val (xncs, vals) = + ListUtil.foldlMap + (fn ((x, n, t), vals) => + if SS.member (vals, x) then + (("?" ^ x, n, t), vals) + else + ((x, n, t), SS.add (vals, x))) + vals xncs + in + ((x, n, xs, xncs), (cons, vals)) + end + + val (dts, (cons, vals)) = ListUtil.foldlMap doOne (cons, vals) dts + in + ((L'.SgiDatatype dts, loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + in + ((L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiVal (x, n, c) => + let + val (vals, x) = + if SS.member (vals, x) then + (vals, "?" ^ x) + else + (SS.add (vals, x), x) + in + ((L'.SgiVal (x, n, c), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiSgn (x, n, sgn) => + let + val (sgns, x) = + if SS.member (sgns, x) then + (sgns, "?" ^ x) + else + (SS.add (sgns, x), x) + in + ((L'.SgiSgn (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) + end + + | L'.SgiStr (im, x, n, sgn) => + let + val (strs, x) = + if SS.member (strs, x) then + (strs, "?" ^ x) + else + (SS.add (strs, x), x) + in + ((L'.SgiStr (im, x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) + | L'.SgiClassAbs (x, n, k) => + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + in + ((L'.SgiClassAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiClass (x, n, k, c) => + let + val (cons, x) = + if SS.member (cons, x) then + (cons, "?" ^ x) + else + (SS.add (cons, x), x) + in + ((L'.SgiClass (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) + end) + + ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis + in + ((L'.StrConst ds', loc), (L'.SgnConst sgis, loc), gs) + end + | L.StrVar x => + (case E.lookupStr env x of + NONE => + (strError env (UnboundStr (loc, x)); + (strerror, sgnerror, [])) + | SOME (n, sgn) => ((L'.StrVar n, loc), sgn, [])) + | L.StrProj (str, x) => + let + val (str', sgn, gs) = elabStr (env, denv) str + in + case E.projectStr env {str = str', sgn = sgn, field = x} of + NONE => (strError env (UnboundStr (loc, x)); + (strerror, sgnerror, [])) + | SOME sgn => ((L'.StrProj (str', x), loc), sgn, gs) + end + | L.StrFun (m, dom, ranO, str) => + let + val (dom', gs1) = elabSgn (env, denv) dom + val (env', n) = E.pushStrNamed env m dom' + val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []} + val (str', actual, gs2) = elabStr (env', denv') str + + val (formal, gs3) = + case ranO of + NONE => (actual, []) + | SOME ran => + let + val (ran', gs) = elabSgn (env', denv') ran + in + subSgn env' loc actual ran'; + (ran', gs) + end + in + ((L'.StrFun (m, n, dom', formal, str'), loc), + (L'.SgnFun (m, n, dom', formal), loc), + enD gs1 @ gs2 @ enD gs3) + end + | L.StrApp (str1, str2) => + let + val (str1', sgn1, gs1) = elabStr (env, denv) str1 + val str2 = + case sgn1 of + (L'.SgnFun (_, _, dom, _), _) => + let + val s = wildifyStr env (str2, dom) + in + (*Print.preface ("Wild", SourcePrint.p_str s);*) + s + end + | _ => str2 + val (str2', sgn2, gs2) = elabStr (env, denv) str2 + in + case #1 (hnormSgn env sgn1) of + L'.SgnError => (strerror, sgnerror, []) + | L'.SgnFun (m, n, dom, ran) => + (subSgn env loc sgn2 dom; + case #1 (hnormSgn env ran) of + L'.SgnError => (strerror, sgnerror, []) + | L'.SgnConst sgis => + let + (* This code handles a tricky case that led to a very nasty bug. + * An invariant about signatures of elaborated modules is that no + * identifier that could appear directly in a program is defined + * twice. We add "?" in front of identifiers where necessary to + * maintain the invariant, but the code below, to extend a functor + * body with a binding for the functor argument, wasn't written + * with the invariant in mind. Luckily for us, references to + * an identifier later within a signature work by globally + * unique index, so we just need to change the string name in the + * new declaration. + * + * ~~~ A few days later.... ~~~ + * This is trickier than I thought! We might need to add + * arbitarily many question marks before the module name to + * avoid a clash, since some other code might depend on + * question-mark identifiers generated previously by this + * very code fragment. *) + fun mungeName m = + if List.exists (fn (L'.SgiStr (_, x, _, _), _) => x = m + | _ => false) sgis then + mungeName ("?" ^ m) + else + m + + val m = mungeName m + in + ((L'.StrApp (str1', str2'), loc), + (L'.SgnConst ((L'.SgiStr (L'.Skip, m, n, selfifyAt env {str = str2', sgn = sgn2}), loc) :: sgis), loc), + gs1 @ gs2) + end + | _ => raise Fail "Unable to hnormSgn in functor application") + | _ => (strError env (NotFunctor sgn1); + (strerror, sgnerror, [])) + end + +fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env + +fun elabFile basis basis_tm topStr topSgn top_tm env file = + let + val () = ModDb.snapshot () + + val () = mayDelay := true + val () = delayedUnifs := [] + val () = delayedExhaustives := [] + + val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan) + val (basis_n, env', sgn) = + case (if !incremental then ModDb.lookup d else NONE) of + NONE => + let + val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan) + val () = case gs of + [] => () + | _ => (app (fn (_, env, _, c1, c2) => + prefaces "Unresolved" + [("c1", p_con env c1), + ("c2", p_con env c2)]) gs; + raise Fail "Unresolved disjointness constraints in Basis") + + val (env', basis_n) = E.pushStrNamed env "Basis" sgn + in + ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm); + (basis_n, env', sgn) + end + | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) => + (basis_n, E.pushStrNamedAs env "Basis" basis_n sgn, sgn) + | _ => raise Fail "Elaborate: Basis impossible" + + val () = basis_r := basis_n + val (ds, env') = dopen env' {str = basis_n, strs = [], sgn = sgn} + + fun discoverC r x = + case E.lookupC env' x of + E.NotBound => raise Fail ("Constructor " ^ x ^ " unbound in Basis") + | E.Rel _ => raise Fail ("Constructor " ^ x ^ " bound relatively in Basis") + | E.Named (n, (_, loc)) => r := (L'.CNamed n, loc) + + val () = discoverC int "int" + val () = discoverC float "float" + val () = discoverC string "string" + val () = discoverC char "char" + val () = discoverC table "sql_table" + + val d = (L.DStr ("Top", SOME (L.SgnConst topSgn, ErrorMsg.dummySpan), + SOME (if Time.< (top_tm, basis_tm) then basis_tm else top_tm), + (L.StrConst topStr, ErrorMsg.dummySpan), false), ErrorMsg.dummySpan) + val (top_n, env', topSgn, topStr) = + case (if !incremental then ModDb.lookup d else NONE) of + NONE => + let + val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan) + val () = case gs of + [] => () + | _ => raise Fail "Unresolved disjointness constraints in top.urs" + val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan) + + val () = case gs of + [] => () + | _ => app (fn Disjoint (loc, env, denv, c1, c2) => + (case D.prove env denv (c1, c2, loc) of + [] => () + | _ => + (prefaces "Unresolved constraint in top.ur" + [("loc", PD.string (ErrorMsg.spanToString loc)), + ("c1", p_con env c1), + ("c2", p_con env c2)]; + raise Fail "Unresolved constraint in top.ur")) + | TypeClass (env, c, r, loc) => + let + val c = normClassKey env c + in + case resolveClass env c of + SOME e => r := SOME e + | NONE => expError env (Unresolvable (loc, c)) + end) gs + + val () = subSgn env' ErrorMsg.dummySpan topSgn' topSgn + + val (env', top_n) = E.pushStrNamed env' "Top" topSgn + in + ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm); + (top_n, env', topSgn, topStr) + end + | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) => + (top_n, E.declBinds env' d', topSgn, topStr) + | _ => raise Fail "Elaborate: Top impossible" + + val () = top_r := top_n + + val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn} + + fun elabDecl' x = + (resetKunif (); + resetCunif (); + elabDecl x) + + val (file, (env'', _, gs)) = ListUtil.foldlMapConcat elabDecl' (env', D.empty, []) file + + fun oneSummaryRound () = + if ErrorMsg.anyErrors () then + () + else + let + val delayed = !delayedUnifs + in + delayedUnifs := []; + app (fn (loc, env, k, s1, s2) => + unifySummaries env (loc, k, normalizeRecordSummary env s1, normalizeRecordSummary env s2)) + delayed + end + + val checkConstraintErrors = ref (fn () => ()) + fun stopHere () = not (!unifyMore) andalso ErrorMsg.anyErrors () + in + oneSummaryRound (); + + if stopHere () then + () + else + let + fun solver (gs : constraint list) = + let + val (gs, solved) = + ListUtil.foldlMapPartial + (fn (g : constraint, solved) => + case g of + Disjoint (loc, env, denv, c1, c2) => + (case D.prove env denv (c1, c2, loc) of + [] => (NONE, true) + | _ => (SOME g, solved)) + | TypeClass (env, c, r, loc) => + let + fun default () = (SOME g, solved) + + fun resolver r c = + let + val c = normClassKey env c + in + case resolveClass env c of + SOME e => (r := SOME e; + (NONE, true)) + | NONE => + case #1 (hnormCon env c) of + L'.CApp (f, x) => + (case (#1 (hnormCon env f), #1 (hnormCon env x)) of + (L'.CKApp (f, _), L'.CRecord (k, xcs)) => + (case #1 (hnormCon env f) of + L'.CModProj (top_n', [], "folder") => + if top_n' = top_n then + let + val e = (L'.EModProj (top_n, ["Folder"], "nil"), loc) + val e = (L'.EKApp (e, k), loc) + + val (folder, _) = foldr (fn ((x, c), (folder, xcs)) => + let + val e = (L'.EModProj (top_n, ["Folder"], + "cons"), loc) + val e = (L'.EKApp (e, k), loc) + val e = (L'.ECApp (e, + (L'.CRecord (k, xcs), + loc)), loc) + val e = (L'.ECApp (e, x), loc) + val e = (L'.ECApp (e, c), loc) + val e = (L'.EApp (e, folder), loc) + in + (e, (x, c) :: xcs) + end) + (e, []) xcs + in + (r := SOME folder; + (NONE, true)) + end + else + default () + | _ => default ()) + | _ => default ()) + + | L'.TRecord c' => + (case #1 (hnormCon env c') of + L'.CRecord (_, xts) => + let + val witnesses = map (fn (x, t) => + let + val r = ref NONE + val (opt, _) = resolver r t + in + case opt of + SOME _ => NONE + | NONE => + case !r of + NONE => NONE + | SOME e => + SOME (x, e, t) + end) xts + in + if List.all Option.isSome witnesses then + (r := SOME (L'.ERecord (map valOf witnesses), loc); + (NONE, true)) + else + (SOME g, solved) + end + | _ => (SOME g, solved)) + + | _ => default () + end + in + resolver r c + end) + false gs + in + case (gs, solved) of + ([], _) => () + | (_, true) => (oneSummaryRound (); solver gs) + | _ => + checkConstraintErrors := + (fn () => app (fn Disjoint (loc, env, denv, c1, c2) => + let + val c1' = ElabOps.hnormCon env c1 + val c2' = ElabOps.hnormCon env c2 + + fun isUnif (c, _) = + case c of + L'.CUnif _ => true + | _ => false + + fun maybeAttr (c, _) = + case c of + L'.CRecord ((L'.KType, _), xts) => true + | _ => false + in + ErrorMsg.errorAt loc "Couldn't prove field name disjointness"; + eprefaces' [("Con 1", p_con env c1), + ("Con 2", p_con env c2), + ("Hnormed 1", p_con env c1'), + ("Hnormed 2", p_con env c2')] + + (*app (fn (loc, env, k, s1, s2) => + eprefaces' [("s1", p_summary env (normalizeRecordSummary env s1)), + ("s2", p_summary env (normalizeRecordSummary env s2))]) + (!delayedUnifs);*) + end + | TypeClass (env, c, r, loc) => + let + val c = normClassKey env c + in + case resolveClass env c of + SOME e => r := SOME e + | NONE => expError env (Unresolvable (loc, c)) + end) + gs) + end + in + solver gs + end; + + mayDelay := false; + + if stopHere () then + () + else + (app (fn (loc, env, k, s1, s2) => + unifySummaries env (loc, k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) + handle CUnify' (env', err) => (ErrorMsg.errorAt loc "Error in final record unification"; + cunifyError env' err; + case !reducedSummaries of + NONE => () + | SOME (s1, s2) => + (ErrorMsg.errorAt loc "Stuck unifying these records after canceling matching pieces:"; + eprefaces' [("Have", s1), + ("Need", s2)]))) + (!delayedUnifs); + delayedUnifs := []); + + if stopHere () then + () + else + if List.exists kunifsInDecl file then + case U.File.findDecl kunifsInDecl file of + NONE => () + | SOME d => declError env'' (KunifsRemain [d]) + else + (); + + if stopHere () then + () + else + if List.exists cunifsInDecl file then + case U.File.findDecl cunifsInDecl file of + NONE => () + | SOME d => declError env'' (CunifsRemain [d]) + else + (); + + if stopHere () then + () + else + app (fn all as (env, _, _, loc) => + case exhaustive all of + NONE => () + | SOME p => expError env (Inexhaustive (loc, p))) + (!delayedExhaustives); + + if stopHere () then + () + else + !checkConstraintErrors (); + + (*preface ("file", p_file env' file);*) + + if !dumpTypes orelse (!dumpTypesOnError andalso ErrorMsg.anyErrors ()) then + let + open L' + open Print.PD + open Print + + fun p_con env c = ElabPrint.p_con env (ElabOps.reduceCon env c) + + fun dumpDecl (d, env) = + case #1 d of + DCon (x, _, k, _) => (print (box [string x, + space, + string "::", + space, + p_kind env k, + newline, + newline]); + E.declBinds env d) + | DVal (x, _, t, _) => (print (box [string x, + space, + string ":", + space, + p_con env t, + newline, + newline]); + E.declBinds env d) + | DValRec vis => (app (fn (x, _, t, _) => print (box [string x, + space, + string ":", + space, + p_con env t, + newline, + newline])) vis; + E.declBinds env d) + | DStr (x, _, _, str) => (print (box [string ("<" ^ x ^ ">"), + newline, + newline]); + dumpStr (str, env); + print (box [string ("</" ^ x ^ ">"), + newline, + newline]); + E.declBinds env d) + | _ => E.declBinds env d + + and dumpStr (str, env) = + case #1 str of + StrConst ds => ignore (foldl dumpDecl env ds) + | _ => () + in + ignore (foldl dumpDecl env' file) + end + else + (); + + if ErrorMsg.anyErrors () then + ModDb.revert () + else + (); + + (*Print.preface("File", ElabPrint.p_file env file);*) + + (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) + :: ds + @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan) + :: ds' @ file + end + handle e => (ModDb.revert (); + raise e) + +end diff --git a/src/elisp/urweb-compat.el b/src/elisp/urweb-compat.el new file mode 100644 index 0000000..b94c2f4 --- /dev/null +++ b/src/elisp/urweb-compat.el @@ -0,0 +1,111 @@ +;;; urweb-compat.el --- Compatibility functions for Emacs variants for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; 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 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, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;;; Code: + +(require 'cl) + +(unless (fboundp 'set-keymap-parents) + (defun set-keymap-parents (m parents) + (if (keymapp parents) (setq parents (list parents))) + (set-keymap-parent + m + (if (cdr parents) + (reduce (lambda (m1 m2) + (let ((m (copy-keymap m1))) + (set-keymap-parent m m2) m)) + parents + :from-end t) + (car parents))))) + +;; for XEmacs +(when (fboundp 'temp-directory) + (defvar temporary-file-directory (temp-directory))) + +(unless (fboundp 'make-temp-file) + ;; Copied from Emacs-21's subr.el + (defun make-temp-file (prefix &optional dir-flag) + "Create a temporary file. +The returned file name (created by appending some random characters at the end +of PREFIX, and expanding against `temporary-file-directory' if necessary, +is guaranteed to point to a newly created empty file. +You can then use `write-region' to write new data into the file. + +If DIR-FLAG is non-nil, create a new empty directory instead of a file." + (let (file) + (while (condition-case () + (progn + (setq file + (make-temp-name + (expand-file-name prefix temporary-file-directory))) + (if dir-flag + (make-directory file) + (write-region "" nil file nil 'silent)) + nil) + (file-already-exists t)) + ;; the file was somehow created by someone else between + ;; `make-temp-name' and `write-region', let's try again. + nil) + file))) + + + +(unless (fboundp 'regexp-opt) + (defun regexp-opt (strings &optional paren) + (let ((open (if paren "\\(" "")) (close (if paren "\\)" ""))) + (concat open (mapconcat 'regexp-quote strings "\\|") close)))) + + +;;;; +;;;; Custom +;;;; + +;; doesn't exist in Emacs < 20.1 +(unless (fboundp 'set-face-bold-p) + (defun set-face-bold-p (face v &optional f) + (when v (ignore-errors (make-face-bold face))))) +(unless (fboundp 'set-face-italic-p) + (defun set-face-italic-p (face v &optional f) + (when v (ignore-errors (make-face-italic face))))) + +;; doesn't exist in Emacs < 20.1 +(ignore-errors (require 'custom)) +(unless (fboundp 'defgroup) + (defmacro defgroup (&rest rest) ())) +(unless (fboundp 'defcustom) + (defmacro defcustom (sym val str &rest rest) `(defvar ,sym ,val ,str))) +(unless (fboundp 'defface) + (defmacro defface (sym val str &rest rest) + `(defvar ,sym (make-face ',sym) ,str))) + +(defvar :group ':group) +(defvar :type ':type) +(defvar :copy ':copy) +(defvar :dense ':dense) +(defvar :inherit ':inherit) +(defvar :suppress ':suppress) + +(provide 'urweb-compat) + +;;; urweb-compat.el ends here diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el new file mode 100644 index 0000000..1b21cba --- /dev/null +++ b/src/elisp/urweb-defs.el @@ -0,0 +1,206 @@ +;;; urweb-defs.el --- Various definitions for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999,2000,2003 Stefan Monnier <monnier@cs.yale.edu> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; 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 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, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'urweb-util) + + +(defgroup urweb () + "Editing Ur/Web code." + :group 'languages) + +(defvar urweb-outline-regexp + ;; `st' and `si' are to match structure and signature. + " \\|s[ti]\\|[ \t]*\\(let[ \t]+\\)?\\(fun\\|and\\)\\>" + "Regexp matching a major heading. +This actually can't work without extending `outline-minor-mode' with the +notion of \"the end of an outline\".") + +;;; +;;; Internal defines +;;; + +(defmap urweb-mode-map + ;; smarter cursor movement + '(("\C-c\C-i" . urweb-mode-info)) + "The keymap used in `urweb-mode'." + ;; :inherit urweb-bindings + :group 'urweb) + +(defsyntax urweb-mode-syntax-table + `((?\* . ,(if urweb-builtin-nested-comments-flag ". 23n" ". 23")) + (?\( . "()1") + (?\) . ")(4") + ("._'" . "_") + (",;" . ".") + ;; `!' is not really a prefix-char, oh well! + ("~#!" . "'") + ("%&$+-/:<=>?@`^|" . ".")) + "The syntax table used in `urweb-mode'.") + + +(easy-menu-define urweb-mode-menu urweb-mode-map "Menu used in `urweb-mode'." + '("Ur/Web" + ["Ur/Web mode help (brief)" describe-mode t] + ["Ur/Web mode *info*" urweb-mode-info t] + )) + +;; Make's sure they appear in the menu bar when urweb-mode-map is active. +;; On the hook for XEmacs only -- see easy-menu-add in auc-menu.el. +;; (defun urweb-mode-menu-bar () +;; "Make sure menus appear in the menu bar as well as under mouse 3." +;; (and (eq major-mode 'urweb-mode) +;; (easy-menu-add urweb-mode-menu urweb-mode-map))) +;; (add-hook 'urweb-mode-hook 'urweb-mode-menu-bar) + +;; +;; regexps +;; + +(defun urweb-syms-re (&rest syms) + (concat "\\<" (regexp-opt (flatten syms) t) "\\>")) + +;; + +(defconst urweb-module-head-syms + '("signature" "structure" "functor")) + + +(defconst urweb-begin-syms + '("let" "struct" "sig") + "Symbols matching the `end' symbol.") + +(defconst urweb-begin-syms-re + (urweb-syms-re urweb-begin-syms) + "Symbols matching the `end' symbol.") + +;; (defconst urweb-user-begin-symbols-re +;; (urweb-syms-re "let" "abstype" "local" "struct" "sig" "in" "with") +;; "Symbols matching (loosely) the `end' symbol.") + +(defconst urweb-sexp-head-symbols-re + (urweb-syms-re "let" "struct" "sig" "in" "with" + "if" "then" "else" "case" "of" "fn" "fun" "val" "and" + "datatype" "type" "open" "include" + urweb-module-head-syms + "con" "map" "where" "extern" "constraint" "constraints" + "table" "sequence" "class" "cookie" "style" "task" "policy") + "Symbols starting an sexp.") + +;; (defconst urweb-not-arg-start-re +;; (urweb-syms-re "in" "of" "end" "andalso") +;; "Symbols that can't be found at the head of an arg.") + +;; (defconst urweb-not-arg-re +;; (urweb-syms-re "in" "of" "end" "andalso") +;; "Symbols that should not be confused with an arg.") + +(defconst urweb-=-starter-syms + (list* "|" "val" "fun" "and" "datatype" "con" "type" "class" + urweb-module-head-syms) + "Symbols that can be followed by a `='.") +(defconst urweb-=-starter-re + (concat "\\S.|\\S.\\|" (urweb-syms-re (cdr urweb-=-starter-syms))) + "Symbols that can be followed by a `='.") + +(defconst urweb-indent-rule + (urweb-preproc-alist + `((,urweb-module-head-syms "d=" 0) + ("if" "else" 0) + (,urweb-=-starter-syms nil) + (("case" "datatype" "if" "then" "else" + "let" "open" "sig" "struct" "type" "val" + "con" "constraint" "table" "sequence" "class" "cookie" + "style" "task" "policy"))))) + +(defconst urweb-starters-indent-after + (urweb-syms-re "let" "in" "struct" "sig") + "Indent after these.") + +(defconst urweb-delegate + (urweb-preproc-alist + `((("of" "else" "then" "with" "d=") . (not (urweb-bolp))) + ("in" . t))) + "Words which might delegate indentation to their parent.") + +(defcustom urweb-symbol-indent + '(("fn" . -3) + ("of" . 1) + ("|" . -2) + ("," . -2) + (";" . -2) + ;;("in" . 1) + ("d=" . 2)) + "Special indentation alist for some symbols. +An entry like (\"in\" . 1) indicates that a line starting with the +symbol `in' should be indented one char further to the right. +This is only used in a few specific cases, so it does not work +for all symbols and in all lines starting with the given symbol." + :group 'urweb + :type '(repeat (cons string integer))) + +(defconst urweb-open-paren + (urweb-preproc-alist + `((,(list* "in" urweb-begin-syms) ,urweb-begin-syms-re "\\<end\\>"))) + "Symbols that should behave somewhat like opening parens.") + +(defconst urweb-close-paren + `(("in" "\\<let\\>") + ("end" ,urweb-begin-syms-re) + ("then" "\\<if\\>") + ("else" "\\<if\\>" (urweb-bolp)) + ("of" "\\<case\\>") + ("</xml>" "<xml>") + ("d=" nil)) + "Symbols that should behave somewhat like close parens.") + +(defconst urweb-agglomerate-re "\\<else[ \t]+if\\>" + "Regexp of compound symbols (pairs of symbols to be considered as one).") + +(defconst urweb-non-nested-of-starter-re + (urweb-syms-re "datatype") + "Symbols that can introduce an `of' that shouldn't behave like a paren.") + +(defconst urweb-starters-syms + (append urweb-module-head-syms + '("datatype" "fun" + "open" "type" "val" "and" + "con" "constraint" "table" "sequence" "class" "cookie" + "style" "task" "policy")) + "The starters of new expressions.") + +(defconst urweb-exptrail-syms + '("if" "then" "else" "case" "of" "fn" "with" "map")) + +(defconst urweb-pipeheads + '("|" "of" "fun" "fn" "and" "datatype") + "A `|' corresponds to one of these.") + + +(provide 'urweb-defs) + +;;; urweb-defs.el ends here diff --git a/src/elisp/urweb-mode-startup.el b/src/elisp/urweb-mode-startup.el new file mode 100644 index 0000000..4812599 --- /dev/null +++ b/src/elisp/urweb-mode-startup.el @@ -0,0 +1,20 @@ + +;;; Generated autoloads from urweb-mode.el + (add-to-list 'load-path (file-name-directory load-file-name)) + +(add-to-list (quote auto-mode-alist) (quote ("\\.ur\\(s\\)?\\'" . urweb-mode))) + +(autoload (quote urweb-mode) "urweb-mode" "\ +\\<urweb-mode-map>Major mode for editing Ur/Web code. +This mode runs `urweb-mode-hook' just before exiting. +\\{urweb-mode-map} + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads nil nil ("urweb-compat.el" "urweb-defs.el" +;;;;;; "urweb-util.el") (18072 34664 948142)) + +;;;*** + diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el new file mode 100644 index 0000000..69b0e23 --- /dev/null +++ b/src/elisp/urweb-mode.el @@ -0,0 +1,930 @@ +;;; urweb-mode.el --- Major mode for editing (Standard) ML + +;; Based on sml-mode: +;; Copyright (C) 1999,2000,2004 Stefan Monnier +;; Copyright (C) 1994-1997 Matthew J. Morley +;; Copyright (C) 1989 Lars Bo Nielsen +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> + +;; Author: Lars Bo Nielsen +;; Olin Shivers +;; Fritz Knabe (?) +;; Steven Gilmore (?) +;; Matthew Morley <mjm@scs.leeds.ac.uk> (aka <matthew@verisity.com>) +;; Matthias Blume <blume@cs.princeton.edu> (aka <blume@kurims.kyoto-u.ac.jp>) +;; (Stefan Monnier) monnier@cs.yale.edu +;; Adam Chlipala + +;; 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: + +;;; HISTORY + +;; Still under construction: History obscure, needs a biographer as +;; well as a M-x doctor. Change Log on request. + +;; Hacked by Olin Shivers for comint from Lars Bo Nielsen's sml.el. + +;; Hacked by Matthew Morley to incorporate Fritz Knabe's hilite and +;; font-lock patterns, some of Steven Gilmore's (reduced) easy-menus, +;; and numerous bugs and bug-fixes. + +;;; DESCRIPTION + +;; See accompanying info file: urweb-mode.info + +;;; FOR YOUR .EMACS FILE + +;; If urweb-mode.el lives in some non-standard directory, you must tell +;; emacs where to get it. This may or may not be necessary: + +;; (add-to-list 'load-path "~jones/lib/emacs/") + +;; Then to access the commands autoload urweb-mode with that command: + +;; (load "urweb-mode-startup") + +;; urweb-mode-hook is run whenever a new urweb-mode buffer is created. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'compile) +(require 'urweb-util) +(require 'urweb-move) +(require 'urweb-defs) +(condition-case nil (require 'skeleton) (error nil)) + +;;; VARIABLES CONTROLLING INDENTATION + +(defcustom urweb-indent-level 4 + "*Indentation of blocks in Ur/Web (see also `urweb-structure-indent')." + :group 'urweb + :type '(integer)) + +(defcustom urweb-indent-args urweb-indent-level + "*Indentation of args placed on a separate line." + :group 'urweb + :type '(integer)) + +(defcustom urweb-electric-semi-mode nil + "*If non-nil, `\;' will self insert, reindent the line, and do a newline. +If nil, just insert a `\;'. (To insert while t, do: \\[quoted-insert] \;)." + :group 'urweb + :type 'boolean) + +(defcustom urweb-rightalign-and t + "If non-nil, right-align `and' with its leader. +If nil: If t: + datatype a = A datatype a = A + and b = B and b = B" + :group 'urweb + :type 'boolean) + +;;; OTHER GENERIC MODE VARIABLES + +(defvar urweb-mode-info "urweb-mode" + "*Where to find Info file for `urweb-mode'. +The default assumes the info file \"urweb-mode.info\" is on Emacs' info +directory path. If it is not, either put the file on the standard path +or set the variable `urweb-mode-info' to the exact location of this file + + (setq urweb-mode-info \"/usr/me/lib/info/urweb-mode\") + +in your .emacs file. You can always set it interactively with the +set-variable command.") + +(defvar urweb-mode-hook nil + "*Run upon entering `urweb-mode'. +This is a good place to put your preferred key bindings.") + +;;; CODE FOR Ur/Web-MODE + +(defun urweb-mode-info () + "Command to access the TeXinfo documentation for `urweb-mode'. +See doc for the variable `urweb-mode-info'." + (interactive) + (require 'info) + (condition-case nil + (info urweb-mode-info) + (error (progn + (describe-variable 'urweb-mode-info) + (message "Can't find it... set this variable first!"))))) + + +;; font-lock setup + +(defconst urweb-keywords-regexp + (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints" + "datatype" "else" "end" "extern" "fn" "map" + "fun" "functor" "if" "include" + "of" "open" "let" "in" + "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" + "struct" "structure" "table" "view" "then" "type" "val" "where" + "with" "ffi" + + "Name" "Type" "Unit") + "A regexp that matches any non-SQL keywords of Ur/Web.") + +(defconst urweb-sql-keywords-regexp + (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" + "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT" + "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX" + "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE" + "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK" + "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL" + "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1" + "IF" "THEN" "ELSE" "COALESCE" "LIKE" "RANDOM") + "A regexp that matches SQL keywords.") + +(defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>" + "A regexp that matches lowercase Ur/Web identifiers.") + +(defconst urweb-cident-regexp "\\<[A-Z][A-Za-z0-9_']*\\>" + "A regexp that matches uppercase Ur/Web identifiers.") + +;;; Font-lock settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; The font lock regular expressions. + +(defun urweb-in-xml () + (save-excursion + (let ( + (depth 0) + (finished nil) + (answer nil) + (bound (max 0 (- (point) 1024))) + ) + (while (and (not finished) + (re-search-backward "\\(\\([-{}]\\)\\|<\\(/?xml\\)?\\)" + bound t)) + (let ((xml-tag (length (or (match-string 3) ""))) + (ch (match-string 2))) + (cond + ((equal ch "{") + (if (> depth 0) + (decf depth) + (setq finished t))) + ((equal ch "}") + (incf depth)) + ((= xml-tag 3) + (if (> depth 0) + (decf depth) + (progn + (setq answer t) + (setq finished t)))) + ((= xml-tag 4) + (incf depth)) + + ((equal ch "-") + (if (looking-at "->") + (setq finished (= depth 0)))) + + ((and (= depth 0) + (not (looking-at "<xml")) ;; ignore <xml/> + (let ((face (get-text-property (point) 'face))) + (funcall (if (listp face) #'member #'equal) 'font-lock-tag-face face))) + ;; previous code was highlighted as tag, seems we are in xml + (progn + (setq answer t) + (setq finished t))) + + ((= depth 0) + ;; previous thing was a tag like, but not tag + ;; seems we are in usual code or comment + (setq finished t)) + ))) + answer))) + +(defun amAttribute (face) + (if (ignore-errors (save-excursion (backward-word 2) (backward-char 1) (looking-at "<"))) + nil + face)) + +(defconst urweb-font-lock-keywords + `(;;(urweb-font-comments-and-strings) + ("\\(<\\sw+\\)\\(\\s-\\|\\sw\\|=\\|\"[^\"]*\"\\|{[^}]*}\\)*\\(/?>\\)" + (1 font-lock-tag-face) + (3 font-lock-tag-face)) + ("\\(</\\sw+>\\)" + (1 font-lock-tag-face)) + ("\\([^<>{}]+\\)" + (1 (if (urweb-in-xml) + font-lock-string-face + nil))) + + ("\\<\\(fun\\|and\\)\\s-+\\(\\sw+\\)\\s-+[^ \t\n=]" + (1 font-lock-keyword-face) + (2 (amAttribute font-lock-function-name-face))) + ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" + (1 font-lock-keyword-face) + (3 (amAttribute font-lock-type-def-face))) + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + (1 font-lock-keyword-face) + (3 (amAttribute font-lock-variable-name-face))) + ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" + (1 font-lock-keyword-face) + (2 (amAttribute font-lock-module-def-face))) + ("\\<\\(signature\\)\\s-+\\(\\sw+\\)" + (1 font-lock-keyword-face) + (2 (amAttribute font-lock-interface-def-face))) + + (,urweb-keywords-regexp . font-lock-keyword-face) + (,urweb-sql-keywords-regexp . font-lock-sql-face) + (,urweb-cident-regexp . font-lock-cvariable-face)) + "Regexps matching standard Ur/Web keywords.") + +(defface font-lock-type-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight type definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-type-def-face 'font-lock-type-def-face + "Face name to use for type definitions.") + +(defface font-lock-module-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight module definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-module-def-face 'font-lock-module-def-face + "Face name to use for module definitions.") + +(defface font-lock-interface-def-face + '((t (:bold t))) + "Font Lock mode face used to highlight interface definitions." + :group 'font-lock-highlighting-faces) +(defvar font-lock-interface-def-face 'font-lock-interface-def-face + "Face name to use for interface definitions.") + +(defface font-lock-sql-face + '((t (:bold t))) + "Font Lock mode face used to highlight SQL keywords." + :group 'font-lock-highlighting-faces) +(defvar font-lock-sql-face 'font-lock-sql-face + "Face name to use for SQL keywords.") + +(defface font-lock-cvariable-face + '((t (:inherit font-lock-type-face))) + "Font Lock mode face used to highlight capitalized identifiers." + :group 'font-lock-highlighting-faces) +(defvar font-lock-cvariable-face 'font-lock-cvariable-face + "Face name to use for capitalized identifiers.") + +(defface font-lock-tag-face + '((t (:bold t))) + "Font Lock mode face used to highlight XML tags." + :group 'font-lock-highlighting-faces) +(defvar font-lock-tag-face 'font-lock-tag-face + "Face name to use for XML tags.") + +(defface font-lock-attr-face + '((t (:bold t))) + "Font Lock mode face used to highlight XML attributes." + :group 'font-lock-highlighting-faces) +(defvar font-lock-attr-face 'font-lock-attr-face + "Face name to use for XML attributes.") + +;; +;; Code to handle nested comments and unusual string escape sequences +;; + +(defsyntax urweb-syntax-prop-table + '((?\\ . ".") (?* . ".")) + "Syntax table for text-properties") + +;; For Emacsen that have no built-in support for nested comments +(defun urweb-get-depth-st () + (save-excursion + (let* ((disp (if (eq (char-before) ?\)) (progn (backward-char) -1) nil)) + (_ (backward-char)) + (disp (if (eq (char-before) ?\() (progn (backward-char) 0) disp)) + (pt (point))) + (when disp + (let* ((depth + (save-match-data + (if (re-search-backward "\\*)\\|(\\*" nil t) + (+ (or (get-char-property (point) 'comment-depth) 0) + (case (char-after) (?\( 1) (?* 0)) + disp) + 0))) + (depth (if (> depth 0) depth))) + (put-text-property pt (1+ pt) 'comment-depth depth) + (when depth urweb-syntax-prop-table)))))) + +(defconst urweb-font-lock-syntactic-keywords + `(("^\\s-*\\(\\\\\\)" (1 ',urweb-syntax-prop-table)) + ,@(unless urweb-builtin-nested-comments-flag + '(("(?\\(\\*\\))?" (1 (urweb-get-depth-st))))))) + +(defconst urweb-font-lock-defaults + '(urweb-font-lock-keywords nil nil ((?_ . "w") (?' . "w")) nil + (font-lock-syntactic-keywords . urweb-font-lock-syntactic-keywords))) + +;;;; +;;;; Imenu support +;;;; + +(defvar urweb-imenu-regexp + (concat "^[ \t]*\\(let[ \t]+\\)?" + (regexp-opt (append urweb-module-head-syms + '("and" "fun" "datatype" "type")) t) + "\\>")) + +(defun urweb-imenu-create-index () + (let (alist) + (goto-char (point-max)) + (while (re-search-backward urweb-imenu-regexp nil t) + (save-excursion + (let ((kind (match-string 2)) + (column (progn (goto-char (match-beginning 2)) (current-column))) + (location + (progn (goto-char (match-end 0)) + (urweb-forward-spaces) + (when (looking-at urweb-tyvarseq-re) + (goto-char (match-end 0))) + (point))) + (name (urweb-forward-sym))) + ;; Eliminate trivial renamings. + (when (or (not (member kind '("structure" "signature"))) + (progn (search-forward "=") + (urweb-forward-spaces) + (looking-at "sig\\|struct"))) + (push (cons (concat (make-string (/ column 2) ?\ ) name) location) + alist))))) + alist)) + +;;; MORE CODE FOR URWEB-MODE + +;;;###autoload (add-to-list 'load-path (file-name-directory load-file-name)) +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.urs?\\'" . urweb-mode)) + +;;;###autoload +(defalias 'urweb-mode-derived-from + (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode)) + +;;;###autoload +(define-derived-mode urweb-mode urweb-mode-derived-from "Ur/Web" + "\\<urweb-mode-map>Major mode for editing Ur/Web code. +This mode runs `urweb-mode-hook' just before exiting. +\\{urweb-mode-map}" + (set (make-local-variable 'font-lock-defaults) urweb-font-lock-defaults) + (set (make-local-variable 'font-lock-multiline) 'undecided) + (set (make-local-variable 'outline-regexp) urweb-outline-regexp) + (set (make-local-variable 'imenu-create-index-function) + 'urweb-imenu-create-index) + (set (make-local-variable 'add-log-current-defun-function) + 'urweb-current-fun-name) + ;; Treat paragraph-separators in comments as paragraph-separators. + (set (make-local-variable 'paragraph-separate) + (concat "\\([ \t]*\\*)?\\)?\\(" paragraph-separate "\\)")) + ;; forward-sexp-function is an experimental variable in my hacked Emacs. + (set (make-local-variable 'forward-sexp-function) 'urweb-user-forward-sexp) + ;; For XEmacs + (easy-menu-add urweb-mode-menu) + + ;; Compatibility. FIXME: we should use `-' in Emacs-CVS. + (unless (boundp 'skeleton-positions) (set (make-local-variable '@) nil)) + + (local-set-key (kbd "C-c C-c") 'compile) + (local-set-key (kbd "C-c /") 'urweb-close-matching-tag) + + (urweb-mode-variables)) + +(defun urweb-mode-variables () + (set-syntax-table urweb-mode-syntax-table) + (setq local-abbrev-table urweb-mode-abbrev-table) + ;; A paragraph is separated by blank lines or ^L only. + + (set (make-local-variable 'indent-line-function) 'urweb-indent-line) + (set (make-local-variable 'comment-start) "(* ") + (set (make-local-variable 'comment-end) " *)") + (set (make-local-variable 'comment-nested) t) + ;;(set (make-local-variable 'block-comment-start) "* ") + ;;(set (make-local-variable 'block-comment-end) "") + ;; (set (make-local-variable 'comment-column) 40) + (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")) + +(defun urweb-funname-of-and () + "Name of the function this `and' defines, or nil if not a function. +Point has to be right after the `and' symbol and is not preserved." + (urweb-forward-spaces) + (if (looking-at urweb-tyvarseq-re) (goto-char (match-end 0))) + (let ((sym (urweb-forward-sym))) + (urweb-forward-spaces) + (unless (or (member sym '(nil "d=")) + (member (urweb-forward-sym) '("d="))) + sym))) + +;;; INDENTATION !!! + +(defun urweb-mark-function () + "Synonym for `mark-paragraph' -- sorry. +If anyone has a good algorithm for this..." + (interactive) + (mark-paragraph)) + +(defun urweb-indent-line () + "Indent current line of Ur/Web code." + (interactive) + (let ((savep (> (current-column) (current-indentation))) + (indent (max (or (ignore-errors (urweb-calculate-indentation)) 0) 0))) + (if savep + (save-excursion (indent-line-to indent)) + (indent-line-to indent)))) + +(defun urweb-back-to-outer-indent () + "Unindents to the next outer level of indentation." + (interactive) + (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (let ((start-column (current-column)) + (indent (current-column))) + (if (> start-column 0) + (progn + (save-excursion + (while (>= indent start-column) + (if (re-search-backward "^[^\n]" nil t) + (setq indent (current-indentation)) + (setq indent 0)))) + (backward-delete-char-untabify (- start-column indent))))))) + +(defun urweb-find-comment-indent () + (save-excursion + (let ((depth 1)) + (while (> depth 0) + (if (re-search-backward "(\\*\\|\\*)" nil t) + (cond + ;; FIXME: That's just a stop-gap. + ((eq (get-text-property (point) 'face) 'font-lock-string-face)) + ((looking-at "*)") (incf depth)) + ((looking-at comment-start-skip) (decf depth))) + (setq depth -1))) + (if (= depth 0) + (1+ (current-column)) + nil)))) + +(defun urweb-empty-line () + (save-excursion + (beginning-of-line) + (let ((start-pos (point))) + (end-of-line) + (not (re-search-backward "[^\n \t]" start-pos t))))) + +(defun urweb-seek-back () + (while (urweb-empty-line) (previous-line 1))) + +(defun urweb-skip-matching-braces () + "Skip backwards past matching brace pairs, to calculate XML indentation after quoted Ur code" + (beginning-of-line) + (let ((start-pos (point)) + (depth 0)) + (end-of-line) + (while (re-search-backward "[{}]" start-pos t) + (cond + ((looking-at "}") + (incf depth)) + ((looking-at "{") + (decf depth)))) + (while (and (> depth 0) (re-search-backward "[{}]" nil t) + (cond + ((looking-at "}") + (incf depth)) + ((looking-at "{") + (decf depth))))))) + +(defun urweb-new-tags () + "Decide if the previous line of XML introduced unclosed tags" + (save-excursion + (let ((start-pos (point)) + (depth 0) + (done nil)) + (previous-line 1) + (urweb-seek-back) + (urweb-skip-matching-braces) + (urweb-seek-back) + (beginning-of-line) + (while (and (not done) (search-forward "<" start-pos t)) + (cond + ((or (looking-at " ") (looking-at "=")) + nil) + ((looking-at "/") + (if (re-search-forward "[^\\sw]>" start-pos t) + (when (> depth 0) (decf depth)) + (setq done t))) + (t + (if (re-search-forward "[^\\sw]>" start-pos t) + (if (not (save-excursion (backward-char 2) (looking-at "/"))) + (incf depth)) + (setq done t))))) + (and (not done) (> depth 0))))) + +(defun urweb-tag-matching-indent () + "Seek back to a matching opener tag and get its line's indent" + (save-excursion + (end-of-line) + (search-backward "</" nil t) + (urweb-tag-matcher) + (beginning-of-line) + (current-indentation))) + +(defun urweb-close-matching-tag () + "Insert a closing XML tag for whatever tag is open at the point." + (interactive) + (assert (urweb-in-xml)) + (save-excursion + (urweb-tag-matcher) + (re-search-forward "<\\([^ ={/>]+\\)" nil t)) + (let ((tag (match-string-no-properties 1))) + (insert "</" tag ">"))) + +(defconst urweb-sql-main-starters + '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE")) + +(defconst urweb-sql-starters + (append urweb-sql-main-starters + '("^\\s-+FROM" "WHERE" "GROUP" "ORDER" "HAVING" "LIMIT" "OFFSET" + "VALUES" "SET"))) + +(defconst urweb-sql-main-starters-re + (urweb-syms-re urweb-sql-main-starters)) +(defconst urweb-sql-starters-re + (urweb-syms-re urweb-sql-starters)) + +(defconst urweb-sql-main-starters-paren-re + (concat "(" urweb-sql-main-starters-re)) + +(defun urweb-in-sql () + "Check if the point is in a block of SQL syntax." + (save-excursion + (let ((start-pos (point)) + (depth 0) + done + (good t)) + (when (re-search-backward urweb-sql-main-starters-paren-re nil t) + (forward-char) + (while (and (not done) (re-search-forward "[()]" start-pos t)) + (save-excursion + (backward-char) + (cond + ((looking-at ")") + (cond + ((= depth 0) (setq done t) (setq good nil)) + (t (decf depth)))) + ((looking-at "(") + (incf depth))))) + good)))) + +(defun urweb-sql-depth () + "Check if the point is in a block of SQL syntax. + Returns the paren nesting depth if so, and nil otherwise." + (save-excursion + (let ((depth 0) + done) + (while (and (not done) + (re-search-backward "[()]" nil t)) + (cond + ((looking-at ")") + (decf depth)) + ((looking-at "(") + (if (looking-at urweb-sql-main-starters-paren-re) + (setq done t) + (incf depth))))) + (max 0 depth)))) + +(defun urweb-calculate-indentation () + (save-excursion + (beginning-of-line) (skip-chars-forward "\t ") + (urweb-with-ist + ;; Indentation for comments alone on a line, matches the + ;; proper indentation of the next line. + (when (looking-at "(\\*") (urweb-forward-spaces)) + (let (data + (sym (save-excursion (urweb-forward-sym)))) + (or + ;; Allow the user to override the indentation. + (when (looking-at (concat ".*" (regexp-quote comment-start) + "[ \t]*fixindent[ \t]*" + (regexp-quote comment-end))) + (current-indentation)) + + ;; Continued comment. + (and (looking-at "\\*") (urweb-find-comment-indent)) + + (and (urweb-in-xml) + (let ((prev-indent (save-excursion + (previous-line 1) + (urweb-seek-back) + (urweb-skip-matching-braces) + (urweb-seek-back) + (current-indentation)))) + (cond + ((looking-at "</") + (urweb-tag-matching-indent)) + ((urweb-new-tags) + (+ prev-indent 2)) + (t + prev-indent)))) + + ;; Continued string ? (Added 890113 lbn) + (and (looking-at "\\\\") + (save-excursion + (if (save-excursion (previous-line 1) + (beginning-of-line) + (looking-at "[\t ]*\\\\")) + (progn (previous-line 1) (current-indentation)) + (if (re-search-backward "[^\\\\]\"" nil t) + (1+ (current-column)) + 0)))) + + ;; Closing parens. Could be handled below with `urweb-indent-relative'? + (and (looking-at "\\s)") + (save-excursion + (skip-syntax-forward ")") + (backward-sexp 1) + (if (urweb-dangling-sym) + (urweb-indent-default 'noindent) + (current-column)))) + + (and (or (looking-at "FROM") (looking-at urweb-sql-starters-re)) + + (save-excursion + (and (re-search-backward urweb-sql-starters-re nil t) + (if (looking-at urweb-sql-main-starters-re) + (current-column) + (current-indentation))))) + + (and (urweb-in-sql) + (setq data (urweb-sql-depth)) + (save-excursion + (re-search-backward urweb-sql-starters-re nil t) + (+ (current-column) 2 (* 2 data)))) + + (and (setq data (assoc sym urweb-close-paren)) + (urweb-indent-relative sym data)) + + (and (member sym urweb-starters-syms) + (urweb-indent-starter sym)) + + (and (string= sym "|") (urweb-indent-pipe)) + + (urweb-indent-arg) + (urweb-indent-default)))))) + +(defsubst urweb-bolp () + (save-excursion (skip-chars-backward " \t|") (bolp))) + +(defun urweb-indent-starter (orig-sym) + "Return the indentation to use for a symbol in `urweb-starters-syms'. +Point should be just before the symbol ORIG-SYM and is not preserved." + (let ((sym (unless (save-excursion (urweb-backward-arg)) + (urweb-backward-spaces) + (urweb-backward-sym)))) + (if (member sym '(";" "d=")) (setq sym nil)) + (if sym (urweb-get-sym-indent sym) + ;; FIXME: this can take a *long* time !! + (setq sym (urweb-find-matching-starter urweb-starters-syms)) + ;; Don't align with `and' because it might be specially indented. + (if (and (or (equal orig-sym "and") (not (equal sym "and"))) + (urweb-bolp)) + (+ (current-column) + (if (and urweb-rightalign-and (equal orig-sym "and")) + (- (length sym) 3) 0)) + (urweb-indent-starter orig-sym))))) + +(defun urweb-indent-relative (sym data) + (save-excursion + (urweb-forward-sym) (urweb-backward-sexp nil) + (unless (second data) (urweb-backward-spaces) (urweb-backward-sym)) + (+ (or (cdr (assoc sym urweb-symbol-indent)) 0) + (urweb-delegated-indent)))) + +(defun urweb-indent-pipe () + (let ((sym (urweb-find-matching-starter urweb-pipeheads + (urweb-op-prec "|" 'back)))) + (when sym + (if (string= sym "|") + (if (urweb-bolp) (current-column) (urweb-indent-pipe)) + (let ((pipe-indent (or (cdr (assoc "|" urweb-symbol-indent)) -2))) + (when (or (member sym '("datatype")) + (and (equal sym "and") + (save-excursion + (forward-word 1) + (not (urweb-funname-of-and))))) + (re-search-forward "=")) + (urweb-forward-sym) + (urweb-forward-spaces) + (+ pipe-indent (current-column))))))) + +(defun urweb-find-forward (re) + (urweb-forward-spaces) + (while (and (not (looking-at re)) + (progn + (or (ignore-errors (forward-sexp 1) t) (forward-char 1)) + (urweb-forward-spaces) + (not (looking-at re)))))) + +(defun urweb-indent-arg () + (and (save-excursion (ignore-errors (urweb-forward-arg))) + ;;(not (looking-at urweb-not-arg-re)) + ;; looks like a function or an argument + (urweb-move-if (urweb-backward-arg)) + ;; an argument + (if (save-excursion (not (urweb-backward-arg))) + ;; a first argument + (+ (current-column) urweb-indent-args) + ;; not a first arg + (while (and (/= (current-column) (current-indentation)) + (urweb-move-if (urweb-backward-arg)))) + (unless (save-excursion (urweb-backward-arg)) + ;; all earlier args are on the same line + (urweb-forward-arg) (urweb-forward-spaces)) + (current-column)))) + +(defun urweb-get-indent (data sym) + (let (d) + (cond + ((not (listp data)) data) + ((setq d (member sym data)) (cadr d)) + ((and (consp data) (not (stringp (car data)))) (car data)) + (t urweb-indent-level)))) + +(defun urweb-dangling-sym () + "Non-nil if the symbol after point is dangling. +The symbol can be an Ur/Web symbol or an open-paren. \"Dangling\" means that +it is not on its own line but is the last element on that line." + (save-excursion + (and (not (urweb-bolp)) + (< (urweb-point-after (end-of-line)) + (urweb-point-after (or (urweb-forward-sym) (skip-syntax-forward "(")) + (urweb-forward-spaces)))))) + +(defun urweb-delegated-indent () + (if (urweb-dangling-sym) + (urweb-indent-default 'noindent) + (urweb-move-if (backward-word 1) + (looking-at urweb-agglomerate-re)) + (current-column))) + +(defun urweb-get-sym-indent (sym &optional style) + "Find the indentation for the SYM we're `looking-at'. +If indentation is delegated, point will move to the start of the parent. +Optional argument STYLE is currently ignored." +;;(assert (equal sym (save-excursion (urweb-forward-sym)))) + (save-excursion + (let ((delegate (and (not (equal sym "end")) (assoc sym urweb-close-paren))) + (head-sym sym)) + (when (and delegate (not (eval (third delegate)))) + ;;(urweb-find-match-backward sym delegate) + (urweb-forward-sym) (urweb-backward-sexp nil) + (setq head-sym + (if (second delegate) + (save-excursion (urweb-forward-sym)) + (urweb-backward-spaces) (urweb-backward-sym)))) + (let ((idata (assoc head-sym urweb-indent-rule))) + (when idata + ;;(if (or style (not delegate)) + ;; normal indentation + (let ((indent (urweb-get-indent (cdr idata) sym))) + (when indent (+ (urweb-delegated-indent) indent))) + ;; delgate indentation to the parent + ;;(urweb-forward-sym) (urweb-backward-sexp nil) + ;;(let* ((parent-sym (save-excursion (urweb-forward-sym))) + ;; (parent-indent (cdr (assoc parent-sym urweb-indent-starters)))) + ;; check the special rules + ;;(+ (urweb-delegated-indent) + ;; (or (urweb-get-indent (cdr indent-data) 1 'strict) + ;; (urweb-get-indent (cdr parent-indent) 1 'strict) + ;; (urweb-get-indent (cdr indent-data) 0) + ;; (urweb-get-indent (cdr parent-indent) 0)))))))) + ))))) + +(defun urweb-indent-default (&optional noindent) + (condition-case nil + (progn + (let* ((sym-after (save-excursion (urweb-forward-sym))) + (_ (urweb-backward-spaces)) + (sym-before (urweb-backward-sym)) + (sym-indent (and sym-before (urweb-get-sym-indent sym-before))) + (indent-after (or (cdr (assoc sym-after urweb-symbol-indent)) 0))) + (when (equal sym-before "end") + ;; I don't understand what's really happening here, but when + ;; it's `end' clearly, we need to do something special. + (forward-word 1) + (setq sym-before nil sym-indent nil)) + (cond + (sym-indent + ;; the previous sym is an indentation introducer: follow the rule + (if noindent + ;;(current-column) + sym-indent + (+ sym-indent indent-after))) + ;; If we're just after a hanging open paren. + ((and (eq (char-syntax (preceding-char)) ?\() + (save-excursion (backward-char) (urweb-dangling-sym))) + (backward-char) + (urweb-indent-default)) + (t + ;; default-default + (let* ((prec-after (urweb-op-prec sym-after 'back)) + (prec (or (urweb-op-prec sym-before 'back) prec-after 100))) + ;; go back until you hit a symbol that has a lower prec than the + ;; "current one", or until you backed over a sym that has the same prec + ;; but is at the beginning of a line. + (while (and (not (urweb-bolp)) + (while (urweb-move-if (urweb-backward-sexp (1- prec)))) + (not (urweb-bolp))) + (while (urweb-move-if (urweb-backward-sexp prec)))) + (if noindent + ;; the `noindent' case does back over an introductory symbol + ;; such as `fun', ... + (progn + (urweb-move-if + (urweb-backward-spaces) + (member (urweb-backward-sym) urweb-starters-syms)) + (current-column)) + ;; Use `indent-after' for cases such as when , or ; should be + ;; outdented so that their following terms are aligned. + (+ (if (progn + (if (equal sym-after ";") + (urweb-move-if + (urweb-backward-spaces) + (member (urweb-backward-sym) urweb-starters-syms))) + (and sym-after (not (looking-at sym-after)))) + indent-after 0) + (current-column)))))))) + (error 0))) + + +;; maybe `|' should be set to word-syntax in our temp syntax table ? +(defun urweb-current-indentation () + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t|") + (current-column))) + + +(defun urweb-find-matching-starter (syms &optional prec) + (let (sym) + (ignore-errors + (while + (progn (urweb-backward-sexp prec) + (setq sym (save-excursion (urweb-forward-sym))) + (not (or (member sym syms) (bobp))))) + (if (member sym syms) sym)))) + +(defun urweb-skip-siblings () + (while (and (not (bobp)) (urweb-backward-arg)) + (urweb-find-matching-starter urweb-starters-syms))) + +(defun urweb-beginning-of-defun () + (let ((sym (urweb-find-matching-starter urweb-starters-syms))) + (if (member sym '("fun" "and" "functor" "signature" "structure" + "datatype")) + (save-excursion (urweb-forward-sym) (urweb-forward-spaces) + (urweb-forward-sym)) + ;; We're inside a "non function declaration": let's skip all other + ;; declarations that we find at the same level and try again. + (urweb-skip-siblings) + ;; Obviously, let's not try again if we're at bobp. + (unless (bobp) (urweb-beginning-of-defun))))) + +(defcustom urweb-max-name-components 3 + "Maximum number of components to use for the current function name." + :group 'urweb + :type 'integer) + +(defun urweb-current-fun-name () + (save-excursion + (let ((count urweb-max-name-components) + fullname name) + (end-of-line) + (while (and (> count 0) + (setq name (urweb-beginning-of-defun))) + (decf count) + (setq fullname (if fullname (concat name "." fullname) name)) + ;; Skip all other declarations that we find at the same level. + (urweb-skip-siblings)) + fullname))) + +(provide 'urweb-mode) + +;;; urweb-mode.el ends here diff --git a/src/elisp/urweb-move.el b/src/elisp/urweb-move.el new file mode 100644 index 0000000..08cd19e --- /dev/null +++ b/src/elisp/urweb-move.el @@ -0,0 +1,373 @@ +;;; urweb-move.el --- Buffer navigation functions for urweb-mode + +;; Based on urweb-mode: +;; Copyright (C) 1999, 2000, 2004 Stefan Monnier <monnier@gnu.org> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; 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 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, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; Commentary: + + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'urweb-util) +(require 'urweb-defs) + +(defsyntax urweb-internal-syntax-table + '((?_ . "w") + (?' . "w") + (?. . "w")) + "Syntax table used for internal urweb-mode operation." + :copy urweb-mode-syntax-table) + +;;; +;;; various macros +;;; + +(defmacro urweb-with-ist (&rest r) + (let ((ost-sym (make-symbol "oldtable"))) + `(let ((,ost-sym (syntax-table)) + (case-fold-search nil) + (parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (unwind-protect + (progn (set-syntax-table urweb-internal-syntax-table) . ,r) + (set-syntax-table ,ost-sym))))) +(def-edebug-spec urweb-with-ist t) + +(defmacro urweb-move-if (&rest body) + (let ((pt-sym (make-symbol "point")) + (res-sym (make-symbol "result"))) + `(let ((,pt-sym (point)) + (,res-sym ,(cons 'progn body))) + (unless ,res-sym (goto-char ,pt-sym)) + ,res-sym))) +(def-edebug-spec urweb-move-if t) + +(defmacro urweb-point-after (&rest body) + `(save-excursion + ,@body + (point))) +(def-edebug-spec urweb-point-after t) + +;; + +(defvar urweb-op-prec + (urweb-preproc-alist + '((("UNION" "INTERSECT" "EXCEPT") . 0) + (("AND" "OR") . 1) + ((">=" "<>" "<=" "=") . 4) + (("+" "-" "^") . 6) + (("*" "%") . 7) + (("NOT") 9))) + "Alist of Ur/Web infix operators and their precedence.") + +(defconst urweb-syntax-prec + (urweb-preproc-alist + `(("," . 20) + (("=>" "d=" "=of") . (65 . 40)) + ("|" . (47 . 30)) + (("case" "of" "fn") . 45) + (("if" "then" "else" ) . 50) + (";" . 53) + (("<-") . 55) + ("||" . 70) + ("&&" . 80) + ((":" ":>") . 90) + ("->" . 95) + ("with" . 100) + (,(cons "end" urweb-begin-syms) . 10000))) + "Alist of pseudo-precedence of syntactic elements.") + +(defun urweb-op-prec (op dir) + "Return the precedence of OP or nil if it's not an infix. +DIR should be set to BACK if you want to precedence w.r.t the left side + and to FORW for the precedence w.r.t the right side. +This assumes that we are `looking-at' the OP." + (when op + (let ((sprec (cdr (assoc op urweb-syntax-prec)))) + (cond + ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec))) + (sprec sprec) + (t + (let ((prec (cdr (assoc op urweb-op-prec)))) + (when prec (+ prec 100)))))))) + +;; + +(defun urweb-forward-spaces () (forward-comment 100000)) +(defun urweb-backward-spaces () (forward-comment -100000)) + + +;; +;; moving forward around matching symbols +;; + +(defun urweb-looking-back-at (re) + (save-excursion + (when (= 0 (skip-syntax-backward "w_")) (backward-char)) + (looking-at re))) + +(defun urweb-find-match-forward (this match) + "Only works for word matches." + (let ((level 1) + (forward-sexp-function nil) + (either (concat this "\\|" match))) + (while (> level 0) + (forward-sexp 1) + (while (not (or (eobp) (urweb-looking-back-at either))) + (condition-case () (forward-sexp 1) (error (forward-char 1)))) + (setq level + (cond + ((and (eobp) (> level 1)) (error "Unbalanced")) + ((urweb-looking-back-at this) (1+ level)) + ((urweb-looking-back-at match) (1- level)) + (t (error "Unbalanced"))))) + t)) + +(defun urweb-find-match-backward (this match) + (let ((level 1) + (forward-sexp-function nil) + (either (concat this "\\|" match))) + (while (> level 0) + (backward-sexp 1) + (while (not (or (bobp) (looking-at either))) + (condition-case () (backward-sexp 1) (error (backward-char 1)))) + (setq level + (cond + ((and (bobp) (> level 1)) (error "Unbalanced")) + ((looking-at this) (1+ level)) + ((looking-at match) (1- level)) + (t (error "Unbalanced"))))) + t)) + +;;; +;;; read a symbol, including the special "op <sym>" case +;;; + +(defmacro urweb-move-read (&rest body) + (let ((pt-sym (make-symbol "point"))) + `(let ((,pt-sym (point))) + ,@body + (when (/= (point) ,pt-sym) + (buffer-substring-no-properties (point) ,pt-sym))))) +(def-edebug-spec urweb-move-read t) + +(defun urweb-poly-equal-p () + (< (urweb-point-after (re-search-backward urweb-=-starter-re nil 'move)) + (urweb-point-after (re-search-backward "=" nil 'move)))) + +(defun urweb-nested-of-p () + (< (urweb-point-after + (re-search-backward urweb-non-nested-of-starter-re nil 'move)) + (urweb-point-after (re-search-backward "\\<case\\>" nil 'move)))) + +(defun urweb-forward-sym-1 () + (or (/= 0 (skip-syntax-forward "'w_")) + (/= 0 (skip-syntax-forward ".'")))) +(defun urweb-forward-sym () + (interactive) + (let ((sym (urweb-move-read (urweb-forward-sym-1)))) + (cond + ((equal "op" sym) + (urweb-forward-spaces) + (concat "op " (or (urweb-move-read (urweb-forward-sym-1)) ""))) + ((equal sym "=") + (save-excursion + (urweb-backward-sym-1) + (if (urweb-poly-equal-p) "=" "d="))) + ((equal sym "of") + (save-excursion + (urweb-backward-sym-1) + (if (urweb-nested-of-p) "of" "=of"))) + ;; ((equal sym "datatype") + ;; (save-excursion + ;; (urweb-backward-sym-1) + ;; (urweb-backward-spaces) + ;; (if (eq (preceding-char) ?=) "=datatype" sym))) + (t sym)))) + +(defun urweb-backward-sym-1 () + (or (/= 0 (skip-syntax-backward ".'")) + (/= 0 (skip-syntax-backward "'w_")))) +(defun urweb-backward-sym () + (interactive) + (let ((sym (urweb-move-read (urweb-backward-sym-1)))) + (let ((result + (when sym + ;; FIXME: what should we do if `sym' = "op" ? + (let ((point (point))) + (urweb-backward-spaces) + (if (equal "op" (urweb-move-read (urweb-backward-sym-1))) + (concat "op " sym) + (goto-char point) + (cond + ((string= sym "=") (if (urweb-poly-equal-p) "=" "d=")) + ((string= sym "of") (if (urweb-nested-of-p) "of" "=of")) + ;; ((string= sym "datatype") + ;; (save-excursion (urweb-backward-spaces) + ;; (if (eq (preceding-char) ?=) "=datatype" sym))) + (t sym))))))) + (if (looking-at ">") + (substring result 1 nil) + result)))) +;; (if (save-excursion (backward-char 5) (looking-at "</xml>")) +;; (progn +;; (backward-char 5) +;; (urweb-tag-matcher) +;; (backward-char) +;; (urweb-backward-sym)) +;; result)))) + +(defun urweb-tag-matcher () + "Seek back to a matching opener tag" + (let ((depth 0) + (done nil)) + (while (and (not done) (search-backward ">" nil t)) + (cond + ((save-excursion (backward-char 1) (looking-at " ")) + nil) + ((save-excursion (backward-char 1) (looking-at "/")) + (when (not (re-search-backward "<[^ =]" nil t)) + (setq done t))) + (t + (if (re-search-backward "<[^ =]" nil t) + (if (looking-at "</") + (incf depth) + (if (= depth 0) + (setq done t) + (decf depth))) + (setq done t))))))) + +(defun urweb-backward-sexp (prec) + "Move one sexp backward if possible, or one char else. +Returns t if the move indeed moved through one sexp and nil if not. +PREC is the precedence currently looked for." + (let ((result (let ((parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (urweb-backward-spaces) + (let* ((op (urweb-backward-sym)) + (op-prec (urweb-op-prec op 'back)) + match) + (cond + ((not op) + (let ((point (point))) + (ignore-errors (let ((forward-sexp-function nil)) (backward-sexp 1))) + (if (/= point (point)) t (ignore-errors (backward-char 1)) nil))) + ;; stop as soon as precedence is smaller than `prec' + ((and prec op-prec (>= prec op-prec)) nil) + ;; special rules for nested constructs like if..then..else + ((and (or (not prec) (and prec op-prec)) + (setq match (second (assoc op urweb-close-paren)))) + (urweb-find-match-backward (concat "\\<" op "\\>") match)) + ;; don't back over open-parens + ((assoc op urweb-open-paren) nil) + ;; infix ops precedence + ((and prec op-prec) (< prec op-prec)) + ;; [ prec = nil ] a new operator, let's skip the sexps until the next + (op-prec (while (urweb-move-if (urweb-backward-sexp op-prec))) t) + ;; special symbols indicating we're getting out of a nesting level + ((string-match urweb-sexp-head-symbols-re op) nil) + ;; if the op was not alphanum, then we still have to do the backward-sexp + ;; this reproduces the usual backward-sexp, but it might be bogus + ;; in this case since !@$% is a perfectly fine symbol + (t t)))))) + (if (save-excursion (backward-char 5) (looking-at "</xml>")) + (progn + (backward-char 5) + (urweb-tag-matcher) + (backward-char) + (urweb-backward-sexp prec)) + result))) + +(defun urweb-forward-sexp (prec) + "Moves one sexp forward if possible, or one char else. +Returns T if the move indeed moved through one sexp and NIL if not." + (let ((parse-sexp-lookup-properties t) + (parse-sexp-ignore-comments t)) + (urweb-forward-spaces) + (let* ((op (urweb-forward-sym)) + (op-prec (urweb-op-prec op 'forw)) + match) + (cond + ((not op) + (let ((point (point))) + (ignore-errors (let ((forward-sexp-function nil)) (forward-sexp 1))) + (if (/= point (point)) t (forward-char 1) nil))) + ;; stop as soon as precedence is smaller than `prec' + ((and prec op-prec (>= prec op-prec)) nil) + ;; special rules for nested constructs like if..then..else + ((and (or (not prec) (and prec op-prec)) + (setq match (cdr (assoc op urweb-open-paren)))) + (urweb-find-match-forward (first match) (second match))) + ;; don't forw over close-parens + ((assoc op urweb-close-paren) nil) + ;; infix ops precedence + ((and prec op-prec) (< prec op-prec)) + ;; [ prec = nil ] a new operator, let's skip the sexps until the next + (op-prec (while (urweb-move-if (urweb-forward-sexp op-prec))) t) + ;; special symbols indicating we're getting out of a nesting level + ((string-match urweb-sexp-head-symbols-re op) nil) + ;; if the op was not alphanum, then we still have to do the backward-sexp + ;; this reproduces the usual backward-sexp, but it might be bogus + ;; in this case since !@$% is a perfectly fine symbol + (t t))))) ;(or (string-match "\\sw" op) (urweb-backward-sexp prec)) + +(defun urweb-in-word-p () + (and (eq ?w (char-syntax (or (char-before) ? ))) + (eq ?w (char-syntax (or (char-after) ? ))))) + +(defun urweb-user-backward-sexp (&optional count) + "Like `backward-sexp' but tailored to the Ur/Web syntax." + (interactive "p") + (unless count (setq count 1)) + (urweb-with-ist + (let ((point (point))) + (if (< count 0) (urweb-user-forward-sexp (- count)) + (when (urweb-in-word-p) (forward-word 1)) + (dotimes (i count) + (unless (urweb-backward-sexp nil) + (goto-char point) + (error "Containing expression ends prematurely"))))))) + + +(defun urweb-user-forward-sexp (&optional count) + "Like `forward-sexp' but tailored to the Ur/Web syntax." + (interactive "p") + (unless count (setq count 1)) + (urweb-with-ist + (let ((point (point))) + (if (< count 0) (urweb-user-backward-sexp (- count)) + (when (urweb-in-word-p) (backward-word 1)) + (dotimes (i count) + (unless (urweb-forward-sexp nil) + (goto-char point) + (error "Containing expression ends prematurely"))))))) + +;;(defun urweb-forward-thing () +;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1))) + +(defun urweb-backward-arg () (interactive) (urweb-backward-sexp 1000)) +(defun urweb-forward-arg () (interactive) (urweb-forward-sexp 1000)) + + +(provide 'urweb-move) + +;;; urweb-move.el ends here diff --git a/src/elisp/urweb-util.el b/src/elisp/urweb-util.el new file mode 100644 index 0000000..55a1e27 --- /dev/null +++ b/src/elisp/urweb-util.el @@ -0,0 +1,123 @@ +;;; urweb-util.el --- Utility functions for urweb-mode + +;; Based on sml-mode: +;; Copyright (C) 1999-2000 Stefan Monnier <monnier@cs.yale.edu> +;; +;; Modified for urweb-mode: +;; Copyright (C) 2008 Adam Chlipala <adamc@hcoop.net> +;; +;; 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 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, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + +;;; Commentary: + +;;; Code: + +(require 'cl) ;for `reduce' +(require 'urweb-compat) + +;; + +(defun flatten (ls &optional acc) + (if (null ls) acc + (let ((rest (flatten (cdr ls) acc)) + (head (car ls))) + (if (listp head) + (flatten head rest) + (cons head rest))))) + +(defun urweb-preproc-alist (al) + "Expand an alist AL where keys can be lists of keys into a normal one." + (reduce (lambda (x al) + (let ((k (car x)) + (v (cdr x))) + (if (consp k) + (append (mapcar (lambda (y) (cons y v)) k) al) + (cons x al)))) + al + :initial-value nil + :from-end t)) + +;;; +;;; defmap +;;; + +(defun custom-create-map (m bs args) + (let (inherit dense suppress) + (while args + (let ((key (first args)) + (val (second args))) + (cond + ((eq key :dense) (setq dense val)) + ((eq key :inherit) (setq inherit val)) + ((eq key :group) ) + ;;((eq key :suppress) (setq suppress val)) + (t (message "Uknown argument %s in defmap" key)))) + (setq args (cddr args))) + (unless (keymapp m) + (setq bs (append m bs)) + (setq m (if dense (make-keymap) (make-sparse-keymap)))) + (dolist (b bs) + (let ((keys (car b)) + (binding (cdr b))) + (dolist (key (if (consp keys) keys (list keys))) + (cond + ((symbolp key) + (substitute-key-definition key binding m global-map)) + ((null binding) + (unless (keymapp (lookup-key m key)) (define-key m key binding))) + ((let ((o (lookup-key m key))) + (or (null o) (numberp o) (eq o 'undefined))) + (define-key m key binding)))))) + (cond + ((keymapp inherit) (set-keymap-parent m inherit)) + ((consp inherit) (set-keymap-parents m inherit))) + m)) + +(defmacro defmap (m bs doc &rest args) + `(defconst ,m + (custom-create-map (if (boundp ',m) ,m) ,bs ,(cons 'list args)) + ,doc)) + +;; defsyntax ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun custom-create-syntax (css args) + (let ((st (make-syntax-table (cadr (memq :copy args))))) + (dolist (cs css) + (let ((char (car cs)) + (syntax (cdr cs))) + (if (sequencep char) + (mapcar* (lambda (c) (modify-syntax-entry c syntax st)) char) + (modify-syntax-entry char syntax st)))) + st)) + +(defmacro defsyntax (st css doc &rest args) + `(defconst ,st (custom-create-syntax ,css ,(cons 'list args)) ,doc)) + +;;;; +;;;; Compatibility info +;;;; + +(defvar urweb-builtin-nested-comments-flag + (ignore-errors + (not (equal (let ((st (make-syntax-table))) + (modify-syntax-entry ?\* ". 23n" st) st) + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\* ". 23" st) st)))) + "Non-nil means this Emacs understands the `n' in syntax entries.") + +(provide 'urweb-util) + +;;; urweb-util.el ends here diff --git a/src/errormsg.sig b/src/errormsg.sig new file mode 100644 index 0000000..9242584 --- /dev/null +++ b/src/errormsg.sig @@ -0,0 +1,56 @@ +(* Copyright (c) 2008, 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 ERROR_MSG = sig + + type pos = {line : int, + char : int} + + type span = {file : string, + first : pos, + last : pos} + + type 'a located = 'a * span + + val posToString : pos -> string + val spanToString : span -> string + + val dummyPos : pos + val dummySpan : span + + val resetPositioning : string -> unit + val newline : int -> unit + val lastLineStart : unit -> int + val posOf : int -> pos + val spanOf : int * int -> span + + val resetErrors : unit -> unit + val anyErrors : unit -> bool + val error : string -> unit + val errorAt : span -> string -> unit + val errorAt' : int * int -> string -> unit +end diff --git a/src/errormsg.sml b/src/errormsg.sml new file mode 100644 index 0000000..8f3c93b --- /dev/null +++ b/src/errormsg.sml @@ -0,0 +1,107 @@ +(* Copyright (c) 2008, 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 ErrorMsg :> ERROR_MSG = struct + +type pos = {line : int, + char : int} + +type span = {file : string, + first : pos, + last : pos} + +type 'a located = 'a * span + + +fun posToString {line, char} = + String.concat [Int.toString line, ":", Int.toString char] + +fun spanToString {file, first, last} = + String.concat [file, ":", posToString first, "-", posToString last] + +val dummyPos = {line = 0, + char = 0} +val dummySpan = {file = "", + first = dummyPos, + last = dummyPos} + + +val file = ref "" +val numLines = ref 1 +val lines : int list ref = ref [] + +fun resetPositioning fname = (file := fname; + numLines := 1; + lines := []) + +fun newline pos = (numLines := !numLines + 1; + lines := pos :: !lines) + +fun lastLineStart () = + case !lines of + [] => 0 + | n :: _ => n+1 + +fun posOf n = + let + fun search lineNum lines = + case lines of + [] => {line = 1, + char = n} + | bound :: rest => + if n > bound then + {line = lineNum, + char = n - bound - 1} + else + search (lineNum - 1) rest + in + search (!numLines) (!lines) + end + +fun spanOf (pos1, pos2) = {file = !file, + first = posOf pos1, + last = posOf pos2} + + +val errors = ref false + +fun resetErrors () = errors := false +fun anyErrors () = !errors +fun error s = (TextIO.output (TextIO.stdErr, s); + TextIO.output1 (TextIO.stdErr, #"\n"); + errors := true) + +fun errorAt (span : span) s = (TextIO.output (TextIO.stdErr, #file span); + TextIO.output (TextIO.stdErr, ":"); + TextIO.output (TextIO.stdErr, posToString (#first span)); + TextIO.output (TextIO.stdErr, ": (to "); + TextIO.output (TextIO.stdErr, posToString (#last span)); + TextIO.output (TextIO.stdErr, ") "); + error s) +fun errorAt' span s = errorAt (spanOf span) s + +end diff --git a/src/especialize.sig b/src/especialize.sig new file mode 100644 index 0000000..135e3a0 --- /dev/null +++ b/src/especialize.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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 ESPECIALIZE = sig + + val specialize : Core.file -> Core.file + + val functionInside : IntBinarySet.set -> Core.con -> bool + +end diff --git a/src/especialize.sml b/src/especialize.sml new file mode 100644 index 0000000..7cf145c --- /dev/null +++ b/src/especialize.sml @@ -0,0 +1,717 @@ +(* Copyright (c) 2008-2013, 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 ESpecialize :> ESPECIALIZE = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +type skey = exp + +structure K = struct +type ord_key = con list * exp list +fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2), + fn () => Order.joinL U.Exp.compare (es1, es2)) +end + +structure KM = BinaryMapFn(K) +structure IM = IntBinaryMap +structure IS = IntBinarySet + +val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => + case e of + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun isPolyT (t, _) = + case t of + TFun (_, ran) => isPolyT ran + | TCFun _ => true + | TKFun _ => true + | _ => false + +fun isPoly (d, _) = + case d of + DVal (_, _, t, _, _) => isPolyT t + | DValRec vis => List.exists (isPolyT o #3) vis + | _ => false + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 + +type func = { + name : string, + args : int KM.map, + body : exp, + typ : con, + tag : string, + constArgs : int (* What length prefix of the arguments never vary across recursive calls? *) +} + +type state = { + maxName : int, + funcs : func IM.map, + decls : (string * int * con * exp * string) list, + specialized : IS.set +} + +fun default (_, x, st) = (x, st) + +fun functionInside known = + U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | TCFun _ => true + | CFfi ("Basis", "transaction") => true + | CFfi ("Basis", "eq") => true + | CFfi ("Basis", "num") => true + | CFfi ("Basis", "ord") => true + | CFfi ("Basis", "show") => true + | CFfi ("Basis", "read") => true + | CFfi ("Basis", "sql_injectable_prim") => true + | CFfi ("Basis", "sql_injectable") => true + | CNamed n => IS.member (known, n) + | _ => false} + +fun getApp (e, _) = + case e of + ENamed f => SOME (f, []) + | EApp (e1, e2) => + (case getApp e1 of + NONE => NONE + | SOME (f, xs) => SOME (f, xs @ [e2])) + | _ => NONE + +val getApp = fn e => case getApp e of + v as SOME (_, _ :: _) => v + | _ => NONE + +val maxInt = Option.getOpt (Int.maxInt, 9999) + +fun calcConstArgs enclosingFunctions e = + let + fun ca depth e = + case #1 e of + EPrim _ => maxInt + | ERel _ => maxInt + | ENamed n => if IS.member (enclosingFunctions, n) then 0 else maxInt + | ECon (_, _, _, NONE) => maxInt + | ECon (_, _, _, SOME e) => ca depth e + | EFfi _ => maxInt + | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs + | EApp (e1, e2) => + let + fun default () = Int.min (ca depth e1, ca depth e2) + in + case getApp e of + NONE => default () + | SOME (f, args) => + if not (IS.member (enclosingFunctions, f)) then + default () + else + let + fun visitArgs (count, args) = + case args of + [] => count + | arg :: args' => + let + fun default () = foldl (fn (e, d) => Int.min (ca depth e, d)) count args + in + case #1 arg of + ERel n => + if n = depth - 1 - count then + visitArgs (count + 1, args') + else + default () + | _ => default () + end + in + visitArgs (0, args) + end + end + | EAbs (_, _, _, e1) => ca (depth + 1) e1 + | ECApp (e1, _) => ca depth e1 + | ECAbs (_, _, e1) => ca depth e1 + | EKAbs (_, e1) => ca depth e1 + | EKApp (e1, _) => ca depth e1 + | ERecord xets => foldl (fn ((_, e, _), d) => Int.min (ca depth e, d)) maxInt xets + | EField (e1, _, _) => ca depth e1 + | EConcat (e1, _, e2, _) => Int.min (ca depth e1, ca depth e2) + | ECut (e1, _, _) => ca depth e1 + | ECutMulti (e1, _, _) => ca depth e1 + | ECase (e1, pes, _) => foldl (fn ((p, e), d) => Int.min (ca (depth + E.patBindsN p) e, d)) (ca depth e1) pes + | EWrite e1 => ca depth e1 + | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es + | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2) + | EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es + + fun enterAbs depth e = + case #1 e of + EAbs (_, _, _, e1) => enterAbs (depth + 1) e1 + | _ => ca depth e + in + enterAbs 0 e + end + + +fun optionExists p opt = + case opt of + NONE => false + | SOME v => p v + +fun specialize' (funcs, specialized) file = + let + val known = foldl (fn (d, known) => + case #1 d of + DCon (_, n, _, c) => + if functionInside known c then + IS.add (known, n) + else + known + | DDatatype dts => + if List.exists (List.exists (optionExists (functionInside known) o #3) o #4) dts then + foldl (fn (dt, known) => IS.add (known, #2 dt)) known dts + else + known + | _ => known) + IS.empty file + + fun bind (env, b) = + case b of + U.Decl.RelE xt => xt :: env + | _ => env + + fun exp (env, e as (_, loc), st : state) = + let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))]*) + + fun default () = + case #1 e of + EPrim _ => (e, st) + | ERel _ => (e, st) + | ENamed _ => (e, st) + | ECon (_, _, _, NONE) => (e, st) + | ECon (dk, pc, cs, SOME e) => + let + val (e, st) = exp (env, e, st) + in + ((ECon (dk, pc, cs, SOME e), loc), st) + end + | EFfi _ => (e, st) + | EFfiApp (m, x, es) => + let + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = exp (env, e, st) + in + ((e, t), st) + end) st es + in + ((EFfiApp (m, x, es), loc), st) + end + | EApp (e1, e2) => + let + val (e1, st) = exp (env, e1, st) + val (e2, st) = exp (env, e2, st) + in + ((EApp (e1, e2), loc), st) + end + | EAbs (x, d, r, e) => + let + val (e, st) = exp ((x, d) :: env, e, st) + in + ((EAbs (x, d, r, e), loc), st) + end + | ECApp (e, c) => + let + val (e, st) = exp (env, e, st) + in + ((ECApp (e, c), loc), st) + end + | ECAbs _ => (e, st) + | EKAbs _ => (e, st) + | EKApp (e, k) => + let + val (e, st) = exp (env, e, st) + in + ((EKApp (e, k), loc), st) + end + | ERecord fs => + let + val (fs, st) = ListUtil.foldlMap (fn ((c1, e, c2), st) => + let + val (e, st) = exp (env, e, st) + in + ((c1, e, c2), st) + end) st fs + in + ((ERecord fs, loc), st) + end + | EField (e, c, cs) => + let + val (e, st) = exp (env, e, st) + in + ((EField (e, c, cs), loc), st) + end + | EConcat (e1, c1, e2, c2) => + let + val (e1, st) = exp (env, e1, st) + val (e2, st) = exp (env, e2, st) + in + ((EConcat (e1, c1, e2, c2), loc), st) + end + | ECut (e, c, cs) => + let + val (e, st) = exp (env, e, st) + in + ((ECut (e, c, cs), loc), st) + end + | ECutMulti (e, c, cs) => + let + val (e, st) = exp (env, e, st) + in + ((ECutMulti (e, c, cs), loc), st) + end + + | ECase (e, pes, cs) => + let + val (e, st) = exp (env, e, st) + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val (e, st) = exp (E.patBindsL p @ env, e, st) + in + ((p, e), st) + end) st pes + in + ((ECase (e, pes, cs), loc), st) + end + + | EWrite e => + let + val (e, st) = exp (env, e, st) + in + ((EWrite e, loc), st) + end + | EClosure (n, es) => + let + val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es + in + ((EClosure (n, es), loc), st) + end + | ELet (x, t, e1, e2) => + let + val (e1, st) = exp (env, e1, st) + val (e2, st) = exp ((x, t) :: env, e2, st) + in + ((ELet (x, t, e1, e2), loc), st) + end + | EServerCall (n, es, t, fm) => + let + val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es + in + ((EServerCall (n, es, t, fm), loc), st) + end + in + case getApp e of + NONE => default () + | SOME (f, xs) => + case IM.find (#funcs st, f) of + NONE => ((*print ("No find: " ^ Int.toString f ^ "\n");*) default ()) + | SOME {name, args, body, typ, tag, constArgs} => + let + val (xs, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st xs + + (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty e)]*) + + val loc = ErrorMsg.dummySpan + + val oldXs = xs + + fun findSplit av (initialPart, constArgs, xs, typ, fxs, fvs) = + let + fun default () = + if initialPart then + ([], oldXs, IS.empty) + else + (rev fxs, xs, fvs) + in + case (#1 typ, xs) of + (TFun (dom, ran), e :: xs') => + if constArgs > 0 then + let + val fi = functionInside known dom + in + if initialPart orelse fi then + findSplit av (not fi andalso initialPart, + constArgs - 1, + xs', + ran, + e :: fxs, + IS.union (fvs, freeVars e)) + else + default () + end + else + default () + | _ => default () + end + + val (fxs, xs, fvs) = findSplit true (true, constArgs, xs, typ, [], IS.empty) + + val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs) + val fxs' = map (squish (IS.listItems fvs)) fxs + + val p_bool = Print.PD.string o Bool.toString + in + (*Print.prefaces "Func" [("name", Print.PD.string name), + ("e", CorePrint.p_exp CoreEnv.empty e), + ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) + if List.all (fn (ERel _, _) => true + | _ => false) fxs' then + default () + else + case KM.find (args, (vts, fxs')) of + SOME f' => + let + val e = (ENamed f', loc) + val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e fvs + val e = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e xs + in + (*Print.prefaces "Brand new (reuse)" + [("e'", CorePrint.p_exp CoreEnv.empty e)];*) + (e, st) + end + | NONE => + let + (*val () = Print.prefaces "New one" + [("name", Print.PD.string name), + ("f", Print.PD.string (Int.toString f)), + ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))), + ("|fxs|", Print.PD.string (Int.toString (length fxs))), + ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'), + ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*) + + (*val () = Print.prefaces ("Yes(" ^ name ^ ")") + [("fxs'", + Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*) + + (*val () = Print.prefaces name + [("Available", Print.PD.string (Int.toString constArgs)), + ("Used", Print.PD.string (Int.toString (length fxs'))), + ("fxs'", + Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*) + + fun subBody (body, typ, fxs') = + case (#1 body, #1 typ, fxs') of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') => + let + val body'' = E.subExpInExp (0, x) body' + in + subBody (body'', + typ', + fxs'') + end + | _ => NONE + in + case subBody (body, typ, fxs') of + NONE => default () + | SOME (body', typ') => + let + val f' = #maxName st + val args = KM.insert (args, (vts, fxs'), f') + val funcs = IM.insert (#funcs st, f, {name = name, + args = args, + body = body, + typ = typ, + tag = tag, + constArgs = calcConstArgs (IS.singleton f) body}) + + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st, + specialized = IS.add (#specialized st, f') + } + + (*val () = Print.prefaces "specExp" + [("f", CorePrint.p_exp env (ENamed f, loc)), + ("f'", CorePrint.p_exp env (ENamed f', loc)), + ("xs", Print.p_list (CorePrint.p_exp env) xs), + ("fxs'", Print.p_list + (CorePrint.p_exp E.empty) fxs'), + ("e", CorePrint.p_exp env (e, loc))]*) + val (body', typ') = IS.foldl (fn (n, (body', typ')) => + let + val (x, xt) = List.nth (env, n) + in + ((EAbs (x, xt, typ', body'), + loc), + (TFun (xt, typ'), loc)) + end) + (body', typ') fvs + (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n")*) + val body' = ReduceLocal.reduceExp body' + (*val () = Print.preface ("PRE", CorePrint.p_exp CoreEnv.empty body')*) + val (body', st) = exp (env, body', st) + + val e' = (ENamed f', loc) + val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e' fvs + val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e' xs + + (*val () = Print.prefaces "Brand new" + [("e'", CorePrint.p_exp CoreEnv.empty e'), + ("e", CorePrint.p_exp CoreEnv.empty e), + ("body'", CorePrint.p_exp CoreEnv.empty body')]*) + in + (e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag) :: #decls st, + specialized = #specialized st}) + end + end + end + end + + fun doDecl (d, (st : state, changed)) = + let + (*val befor = Time.now ()*) + + val funcs = #funcs st + val funcs = + case #1 d of + DValRec vis => + let + val fs = foldl (fn ((_, n, _, _, _), fs) => IS.add (fs, n)) IS.empty vis + val constArgs = foldl (fn ((_, _, _, e, _), constArgs) => + Int.min (constArgs, calcConstArgs fs e)) + maxInt vis + in + (*Print.prefaces "ConstArgs" [("d", CorePrint.p_decl CoreEnv.empty d), + ("ca", Print.PD.string (Int.toString constArgs))];*) + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = KM.empty, + body = e, + typ = c, + tag = tag, + constArgs = constArgs})) + funcs vis + end + | _ => funcs + + val st = {maxName = #maxName st, + funcs = funcs, + decls = [], + specialized = #specialized st} + + (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) + + val (d', st) = + if isPoly d then + (d, st) + else + case #1 d of + DVal (x, n, t, e, s) => + let + (*val () = Print.preface ("Visiting", Print.box [Print.PD.string (x ^ "__" ^ Int.toString n), + Print.space, + Print.PD.string ":", + Print.space, + CorePrint.p_con CoreEnv.empty t])*) + + val (e, st) = exp ([], e, st) + in + ((DVal (x, n, t, e, s), #2 d), st) + end + | DValRec vis => + let + (*val () = Print.preface ("Visiting", Print.p_list (fn vi => + Print.box [Print.PD.string (#1 vi ^ "__" + ^ Int.toString + (#2 vi)), + Print.space, + Print.PD.string ":", + Print.space, + CorePrint.p_con CoreEnv.empty (#3 vi)]) + vis)*) + + val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => + let + val (e, st) = exp ([], e, st) + in + ((x, n, t, e, s), st) + end) st vis + in + ((DValRec vis, #2 d), st) + end + | DTable (s, n, t, s1, e1, t1, e2, t2) => + let + val (e1, st) = exp ([], e1, st) + val (e2, st) = exp ([], e2, st) + in + ((DTable (s, n, t, s1, e1, t2, e2, t2), #2 d), st) + end + | DView (x, n, s, e, t) => + let + val (e, st) = exp ([], e, st) + in + ((DView (x, n, s, e, t), #2 d), st) + end + | DTask (e1, e2) => + let + val (e1, st) = exp ([], e1, st) + val (e2, st) = exp ([], e2, st) + in + ((DTask (e1, e2), #2 d), st) + end + | _ => (d, st) + + (*val () = print "/decl\n"*) + + val funcs = #funcs st + val funcs = + case #1 d of + DVal (x, n, c, e as (EAbs _, _), tag) => + ((*Print.prefaces "ConstArgs[2]" [("d", CorePrint.p_decl CoreEnv.empty d), + ("ca", Print.PD.string (Int.toString (calcConstArgs (IS.singleton n) e)))];*) + IM.insert (funcs, n, {name = x, + args = KM.empty, + body = e, + typ = c, + tag = tag, + constArgs = calcConstArgs (IS.singleton n) e})) + | DVal (_, n, _, (ENamed n', _), _) => + (case IM.find (funcs, n') of + NONE => funcs + | SOME v => IM.insert (funcs, n, v)) + | _ => funcs + + val (changed, ds) = + case #decls st of + [] => (changed, [d']) + | vis => + (true, case d' of + (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] + | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) + in + (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d), + ("d'", CorePrint.p_decl E.empty d')];*) + (ds, ({maxName = #maxName st, + funcs = funcs, + decls = [], + specialized = #specialized st}, changed)) + end + + (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*) + val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl + ({maxName = U.File.maxName file + 1, + funcs = funcs, + decls = [], + specialized = specialized}, + false) + file + in + (*print ("Changed = " ^ Bool.toString changed ^ "\n");*) + (changed, ds, #funcs st, #specialized st) + end + +fun specializeL (funcs, specialized) file = + let + val file = ReduceLocal.reduce file + (*val file = ReduceLocal.reduce file*) + val (changed, file, funcs, specialized) = specialize' (funcs, specialized) file + (*val file = ReduceLocal.reduce file + val file = CoreUntangle.untangle file + val file = Shake.shake file*) + in + (*print "Round over\n";*) + if changed then + let + (*val file = ReduceLocal.reduce file*) + (*val () = Print.prefaces "Pre-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*) + val file = CoreUntangle.untangle file + (*val () = Print.prefaces "Post-untangle" [("file", CorePrint.p_file CoreEnv.empty file)]*) + val file = Shake.shake file + in + (*print "Again!\n";*) + (*Print.prefaces "Again" [("file", CorePrint.p_file CoreEnv.empty file)];*) + specializeL (funcs, specialized) file + end + else + file + end + +val specialize = specializeL (IM.empty, IS.empty) + +end diff --git a/src/expl.sml b/src/expl.sml new file mode 100644 index 0000000..994c05c --- /dev/null +++ b/src/expl.sml @@ -0,0 +1,166 @@ +(* Copyright (c) 2008, 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 Expl = struct + +type 'a located = 'a ErrorMsg.located + +datatype kind' = + KType + | KArrow of kind * kind + | KName + | KUnit + | KTuple of kind list + | KRecord of kind + + | KRel of int + | KFun of string * kind + +withtype kind = kind' located + +datatype con' = + TFun of con * con + | TCFun of string * kind * con + | TRecord of con + + | CRel of int + | CNamed of int + | CModProj of int * string list * string + | CApp of con * con + | CAbs of string * kind * con + + | CKAbs of string * con + | CKApp of con * kind + | TKFun of string * con + + | CName of string + + | CRecord of kind * (con * con) list + | CConcat of con * con + | CMap of kind * kind + + | CUnit + + | CTuple of con list + | CProj of con * int + +withtype con = con' located + +datatype datatype_kind = datatype DatatypeKind.datatype_kind + +datatype patCon = + PConVar of int + | PConProj of int * string list * string + +datatype pat' = + PVar of string * con + | PPrim of Prim.t + | PCon of datatype_kind * patCon * con list * pat option + | PRecord of (string * pat * con) list + +withtype pat = pat' located + +datatype exp' = + EPrim of Prim.t + | ERel of int + | ENamed of int + | EModProj of int * string list * string + | EApp of exp * exp + | EAbs of string * con * con * exp + | ECApp of exp * con + | ECAbs of string * kind * exp + + | EKAbs of string * exp + | EKApp of exp * kind + + | ERecord of (con * exp * con) list + | EField of exp * con * { field : con, rest : con } + | EConcat of exp * con * exp * con + | ECut of exp * con * { field : con, rest : con } + | ECutMulti of exp * con * { rest : con } + + | ECase of exp * (pat * exp) list * { disc : con, result : con } + + | EWrite of exp + + | ELet of string * con * exp * exp + +withtype exp = exp' located + +datatype sgn_item' = + SgiConAbs of string * int * kind + | SgiCon of string * int * kind * con + | SgiDatatype of (string * int * string list * (string * int * con option) list) list + | SgiDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list + | SgiVal of string * int * con + | SgiSgn of string * int * sgn + | SgiStr of string * int * sgn + +and sgn' = + SgnConst of sgn_item list + | SgnVar of int + | SgnFun of string * int * sgn * sgn + | SgnWhere of sgn * string list * string * con + | SgnProj of int * string list * string + +withtype sgn_item = sgn_item' located +and sgn = sgn' located + +datatype decl' = + DCon of string * int * kind * con + | DDatatype of (string * int * string list * (string * int * con option) list) list + | DDatatypeImp of string * int * int * string list * string * string list * (string * int * con option) list + | DVal of string * int * con * exp + | DValRec of (string * int * con * exp) list + | DSgn of string * int * sgn + | DStr of string * int * sgn * str + | DFfiStr of string * int * sgn + | DExport of int * sgn * str + | DTable of int * string * int * con * exp * con * exp * con + | DSequence of int * string * int + | DView of int * string * int * exp * con + | DDatabase of string + | DCookie of int * string * int * con + | DStyle of int * string * int + | DTask of exp * exp + | DPolicy of exp + | DOnError of int * string list * string + | DFfi of string * int * Source.ffi_mode list * con + + and str' = + StrConst of decl list + | StrVar of int + | StrProj of str * string + | StrFun of string * int * sgn * sgn * str + | StrApp of str * str + +withtype decl = decl' located + and str = str' located + +type file = decl list + +end diff --git a/src/expl_env.sig b/src/expl_env.sig new file mode 100644 index 0000000..89594d0 --- /dev/null +++ b/src/expl_env.sig @@ -0,0 +1,71 @@ +(* 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. + *) + +signature EXPL_ENV = sig + + exception SynUnif + val liftConInCon : int -> Expl.con -> Expl.con + + type env + + val empty : env + + exception UnboundRel of int + exception UnboundNamed of int + + datatype 'a var = + NotBound + | Rel of int * 'a + | Named of int * 'a + + val pushKRel : env -> string -> env + val lookupKRel : env -> int -> string + + val pushCRel : env -> string -> Expl.kind -> env + val lookupCRel : env -> int -> string * Expl.kind + + val pushCNamed : env -> string -> int -> Expl.kind -> Expl.con option -> env + val lookupCNamed : env -> int -> string * Expl.kind * Expl.con option + + val pushERel : env -> string -> Expl.con -> env + val lookupERel : env -> int -> string * Expl.con + + val pushENamed : env -> string -> int -> Expl.con -> env + val lookupENamed : env -> int -> string * Expl.con + + val pushSgnNamed : env -> string -> int -> Expl.sgn -> env + val lookupSgnNamed : env -> int -> string * Expl.sgn + + val pushStrNamed : env -> string -> int -> Expl.sgn -> env + val lookupStrNamed : env -> int -> string * Expl.sgn + + val declBinds : env -> Expl.decl -> env + val sgiBinds : env -> Expl.sgn_item -> env + + val patBinds : env -> Expl.pat -> env + +end diff --git a/src/expl_env.sml b/src/expl_env.sml new file mode 100644 index 0000000..f7f51be --- /dev/null +++ b/src/expl_env.sml @@ -0,0 +1,413 @@ +(* 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 ExplEnv :> EXPL_ENV = struct + +open Expl + +structure U = ExplUtil + +structure IM = IntBinaryMap +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +exception UnboundRel of int +exception UnboundNamed of int + + +(* AST utility functions *) + +exception SynUnif + +val liftKindInKind = + U.Kind.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + bind = fn (bound, _) => bound + 1} + +val liftKindInCon = + U.Con.mapB {kind = fn bound => fn k => + case k of + KRel xn => + if xn < bound then + k + else + KRel (xn + 1) + | _ => k, + con = fn _ => fn c => c, + bind = fn (bound, U.Con.RelK _) => bound + 1 + | (bound, _) => bound} + +val liftConInCon = + U.Con.mapB {kind = fn _ => fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + (*| CUnif _ => raise SynUnif*) + | _ => c, + bind = fn (bound, U.Con.RelC _) => bound + 1 + | (bound, _) => bound} + +val lift = liftConInCon 0 + + +(* Back to environments *) + +datatype 'a var' = + Rel' of int * 'a + | Named' of int * 'a + +datatype 'a var = + NotBound + | Rel of int * 'a + | Named of int * 'a + +type env = { + relK : string list, + + relC : (string * kind) list, + namedC : (string * kind * con option) IM.map, + + relE : (string * con) list, + namedE : (string * con) IM.map, + + sgn : (string * sgn) IM.map, + + str : (string * sgn) IM.map +} + +val namedCounter = ref 0 + +val empty = { + relK = [], + + relC = [], + namedC = IM.empty, + + relE = [], + namedE = IM.empty, + + sgn = IM.empty, + + str = IM.empty +} + +fun pushKRel (env : env) x = + {relK = x :: #relK env, + + relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env), + namedC = #namedC env, + + relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env), + namedE = #namedE env, + + sgn = #sgn env, + + str = #str env + } + +fun lookupKRel (env : env) n = + (List.nth (#relK env, n)) + handle Subscript => raise UnboundRel n + +fun pushCRel (env : env) x k = + {relK = #relK env, + + relC = (x, k) :: #relC env, + namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), + + relE = map (fn (x, c) => (x, lift c)) (#relE env), + namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env), + + sgn = #sgn env, + + str = #str env + } + +fun lookupCRel (env : env) n = + (List.nth (#relC env, n)) + handle Subscript => raise UnboundRel n + +fun pushCNamed (env : env) x n k co = + {relK = #relK env, + + relC = #relC env, + namedC = IM.insert (#namedC env, n, (x, k, co)), + + relE = #relE env, + namedE = #namedE env, + + sgn = #sgn env, + + str = #str env} + +fun lookupCNamed (env : env) n = + case IM.find (#namedC env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushERel (env : env) x t = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + relE = (x, t) :: #relE env, + namedE = #namedE env, + + sgn = #sgn env, + + str = #str env} + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun pushENamed (env : env) x n t = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t)), + + sgn = #sgn env, + + str = #str env} + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushSgnNamed (env : env) x n sgis = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + relE = #relE env, + namedE = #namedE env, + + sgn = IM.insert (#sgn env, n, (x, sgis)), + + str = #str env} + +fun lookupSgnNamed (env : env) n = + case IM.find (#sgn env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun pushStrNamed (env : env) x n sgis = + {relK = #relK env, + + relC = #relC env, + namedC = #namedC env, + + relE = #relE env, + namedE = #namedE env, + + sgn = #sgn env, + + str = IM.insert (#str env, n, (x, sgis))} + +fun lookupStrNamed (env : env) n = + case IM.find (#str env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun declBinds env (d, loc) = + case d of + DCon (x, n, k, c) => pushCNamed env x n k (SOME c) + | DDatatype dts => + let + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val nxs = length xs + val (tb, kb) = ListUtil.foldli (fn (i, x', (tb, kb)) => + ((CApp (tb, (CRel (nxs - i - 1), loc)), loc), + (KArrow (k, kb), loc))) + ((CNamed n, loc), k) xs + + val env = pushCNamed env x n kb NONE + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => tb + | SOME t => (TFun (t, tb), loc) + val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs + in + pushENamed env x' n' t + end) + env xncs + end + in + foldl doOne env dts + end + | DDatatypeImp (x, n, m, ms, x', xs, xncs) => + let + val t = (CModProj (m, ms, x'), loc) + val env = pushCNamed env x n (KType, loc) (SOME t) + + val t = (CNamed n, loc) + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs + in + pushENamed env x' n' t + end) + env xncs + end + | DVal (x, n, t, _) => pushENamed env x n t + | DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamed env x n t) env vis + | DSgn (x, n, sgn) => pushSgnNamed env x n sgn + | DStr (x, n, sgn, _) => pushStrNamed env x n sgn + | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn + | DExport _ => env + | DTable (tn, x, n, c, _, pc, _, cc) => + let + val ct = (CModProj (tn, [], "sql_table"), loc) + val ct = (CApp (ct, c), loc) + val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc) + in + pushENamed env x n ct + end + | DSequence (tn, x, n) => + let + val t = (CModProj (tn, [], "sql_sequence"), loc) + in + pushENamed env x n t + end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct + end + | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) + in + pushENamed env x n t + end + | DStyle (tn, x, n) => + let + val t = (CModProj (tn, [], "css_class"), loc) + in + pushENamed env x n t + end + | DTask _ => env + | DPolicy _ => env + | DOnError _ => env + | DFfi (x, n, _, t) => pushENamed env x n t + +fun sgiBinds env (sgi, loc) = + case sgi of + SgiConAbs (x, n, k) => pushCNamed env x n k NONE + | SgiCon (x, n, k, c) => pushCNamed env x n k (SOME c) + | SgiDatatype dts => + let + fun doOne ((x, n, xs, xncs), env) = + let + val k = (KType, loc) + val k' = foldr (fn (_, k') => (KArrow (k, k'), loc)) k xs + + val env = pushCNamed env x n k' NONE + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) + + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs + in + pushENamed env x' n' t + end) + env xncs + end + in + foldl doOne env dts + end + | SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) => + let + val t = (CModProj (m1, ms, x'), loc) + val env = pushCNamed env x n (KType, loc) (SOME t) + + val t = (CNamed n, loc) + in + foldl (fn ((x', n', to), env) => + let + val t = + case to of + NONE => (CNamed n, loc) + | SOME t => (TFun (t, (CNamed n, loc)), loc) + val k = (KType, loc) + val t = foldr (fn (x, t) => (TCFun (x, k, t), loc)) t xs + in + pushENamed env x' n' t + end) + env xncs + end + | SgiVal (x, n, t) => pushENamed env x n t + | SgiSgn (x, n, sgn) => pushSgnNamed env x n sgn + | SgiStr (x, n, sgn) => pushStrNamed env x n sgn + +fun patBinds env (p, loc) = + case p of + PVar (x, t) => pushERel env x t + | PPrim _ => env + | PCon (_, _, _, NONE) => env + | PCon (_, _, _, SOME p) => patBinds env p + | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps + +end diff --git a/src/expl_print.sig b/src/expl_print.sig new file mode 100644 index 0000000..3b07401 --- /dev/null +++ b/src/expl_print.sig @@ -0,0 +1,39 @@ +(* Copyright (c) 2008, 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 EXPL_PRINT = sig + val p_kind : ExplEnv.env -> Expl.kind Print.printer + val p_con : ExplEnv.env -> Expl.con Print.printer + val p_exp : ExplEnv.env -> Expl.exp Print.printer + val p_decl : ExplEnv.env -> Expl.decl Print.printer + val p_sgn_item : ExplEnv.env -> Expl.sgn_item Print.printer + val p_str : ExplEnv.env -> Expl.str Print.printer + val p_file : ExplEnv.env -> Expl.file Print.printer + + val debug : bool ref +end + diff --git a/src/expl_print.sml b/src/expl_print.sml new file mode 100644 index 0000000..10ea605 --- /dev/null +++ b/src/expl_print.sml @@ -0,0 +1,794 @@ +(* 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. + *) + +(* Pretty-printing elaborated Ur/Web *) + +structure ExplPrint :> EXPL_PRINT = struct + +open Print.PD +open Print + +open Expl + +structure E = ExplEnv + +val debug = ref false + +fun p_kind' par env (k, _) = + case k of + KType => string "Type" + | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, + space, + string "->", + space, + p_kind env k2]) + | KName => string "Name" + | KRecord k => box [string "{", p_kind env k, string "}"] + | KUnit => string "Unit" + | KTuple ks => box [string "(", + p_list_sep (box [space, string "*", space]) (p_kind env) ks, + string ")"] + + | KRel n => ((if !debug then + string (E.lookupKRel env n ^ "_" ^ Int.toString n) + else + string (E.lookupKRel env n)) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind (E.pushKRel env x) k] + +and p_kind env = p_kind' false env + +fun p_con' par env (c, _) = + case c of + TFun (t1, t2) => parenIf par (box [p_con' true env t1, + space, + string "->", + space, + p_con env t2]) + | TCFun (x, k, c) => parenIf par (box [string x, + space, + string "::", + space, + p_kind env k, + space, + string "->", + space, + p_con (E.pushCRel env x k) c]) + | TRecord (CRecord (_, xcs), _) => box [string "{", + p_list (fn (x, c) => + box [p_name env x, + space, + string ":", + space, + p_con env c]) xcs, + string "}"] + | TRecord c => box [string "$", + p_con' true env c] + + | CRel n => + ((if !debug then + string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupCRel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | CNamed n => + ((if !debug then + string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupCNamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | CModProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString m1 + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1s :: ms @ [x]) + end + + | CApp (c1, c2) => parenIf par (box [p_con env c1, + space, + p_con' true env c2]) + | CAbs (x, k, c) => parenIf par (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind env k, + space, + string "=>", + space, + p_con (E.pushCRel env x k) c]) + + | CName s => box [string "#", string s] + + | CRecord (k, xcs) => + if !debug then + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_con env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]::", + p_kind env k]) + else + parenIf par (box [string "[", + p_list (fn (x, c) => + box [p_con env x, + space, + string "=", + space, + p_con env c]) xcs, + string "]"]) + | CConcat (c1, c2) => parenIf par (box [p_con' true env c1, + space, + string "++", + space, + p_con env c2]) + | CMap _ => string "map" + | CUnit => string "()" + + | CTuple cs => box [string "(", + p_list (p_con env) cs, + string ")"] + | CProj (c, n) => box [p_con env c, + string ".", + string (Int.toString n)] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con (E.pushKRel env x) c] + | CKApp (c, k) => box [p_con env c, + string "[[", + p_kind env k, + string "]]"] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con (E.pushKRel env x) c] + +and p_con env = p_con' false env + +and p_name env (all as (c, _)) = + case c of + CName s => string s + | _ => p_con env all + +fun p_patCon env pc = + case pc of + PConVar n => + ((if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | PConProj (m1, ms, x) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1x :: ms @ [x]) + end + +fun p_pat' par env (p, _) = + case p of + PVar (s, _) => string s + | PPrim p => Prim.p_t p + | PCon (_, pc, _, NONE) => p_patCon env pc + | PCon (_, pc, cs, SOME p) => + if !debug then + parenIf par (box [p_patCon env pc, + string "[", + p_list (p_con env) cs, + string "]", + space, + p_pat' true env p]) + else + parenIf par (box [p_patCon env pc, + space, + p_pat' true env p]) + + | PRecord xps => + box [string "{", + p_list_sep (box [string ",", space]) (fn (x, p, t) => + box [string x, + space, + string "=", + space, + p_pat env p, + if !debug then + box [space, + string ":", + space, + p_con env t] + else + box []]) xps, + string "}"] + +and p_pat x = p_pat' false x + +fun p_exp' par env (e, loc) = + case e of + EPrim p => Prim.p_t p + | ERel n => + ((if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) + | ENamed n => + ((if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + | EModProj (m1, ms, x) => + let + val (m1x, sgn) = E.lookupStrNamed env m1 + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1s :: ms @ [x]) + end + + | EApp (e1, e2) => parenIf par (box [p_exp env e1, + space, + p_exp' true env e2]) + | EAbs (x, t, _, e) => parenIf par (box [string "fn", + space, + string x, + space, + string ":", + space, + p_con env t, + space, + string "=>", + space, + p_exp (E.pushERel env x t) e]) + | ECApp (e, c) => parenIf par (box [p_exp env e, + space, + string "[", + p_con env c, + string "]"]) + | ECAbs (x, k, e) => parenIf par (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind env k, + space, + string "=>", + space, + p_exp (E.pushCRel env x k) e]) + + | ERecord xes => box [string "{", + p_list (fn (x, e, _) => + box [p_name env x, + space, + string "=", + space, + p_exp env e]) xes, + string "}"] + | EField (e, c, {field, rest}) => + if !debug then + box [p_exp' true env e, + string ".", + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + string ".", + p_con' true env c] + | EConcat (e1, c1, e2, c2) => + parenIf par (if !debug then + box [p_exp' true env e1, + space, + string ":", + space, + p_con env c1, + space, + string "++", + space, + p_exp' true env e2, + space, + string ":", + space, + p_con env c2] + else + box [p_exp' true env e1, + space, + string "with", + space, + p_exp' true env e2]) + | ECut (e, c, {field, rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c, + space, + string "[", + p_con env field, + space, + string " in ", + space, + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "--", + space, + p_con' true env c]) + | ECutMulti (e, c, {rest}) => + parenIf par (if !debug then + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c, + space, + string "[", + p_con env rest, + string "]"] + else + box [p_exp' true env e, + space, + string "---", + space, + p_con' true env c]) + + | EWrite e => box [string "write(", + p_exp env e, + string ")"] + + | ECase (e, pes, {disc, result}) => + parenIf par (box [string "case", + space, + p_exp env e, + space, + if !debug then + box [string "in", + space, + p_con env disc, + space, + string "return", + space, + p_con env result, + space] + else + box [], + string "of", + space, + p_list_sep (box [space, string "|", space]) + (fn (p, e) => box [p_pat env p, + space, + string "=>", + space, + p_exp (E.patBinds env p) e]) pes]) + + | ELet (x, t, e1, e2) => box [string "let", + space, + string x, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e1, + space, + string "in", + newline, + p_exp (E.pushERel env x t) e2] + + | EKAbs (x, e) => box [string x, + space, + string "==>", + space, + p_exp (E.pushKRel env x) e] + | EKApp (e, k) => box [p_exp env e, + string "[[", + p_kind env k, + string "]]"] + + +and p_exp env = p_exp' false env + +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + +fun p_datatype env (x, n, xs, cons) = + let + val k = (KType, ErrorMsg.dummySpan) + val env = E.pushCNamed env x n k NONE + val env = foldl (fn (x, env) => E.pushCRel env x k) env xs + in + box [string x, + p_list_sep (box []) (fn x => box [space, string x]) xs, + space, + string "=", + space, + p_list_sep (box [space, string "|", space]) + (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x + | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x, space, string "of", space, p_con env t]) + cons] + end + +fun p_sgn_item env (sgiAll as (sgi, _)) = + case sgi of + SgiConAbs (x, n, k) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k] + | SgiCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + | SgiDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x] + | SgiDatatypeImp (x, _, m1, ms, x', _, _) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + in + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (m1x :: ms @ [x'])] + end + | SgiVal (x, n, c) => box [string "val", + space, + p_named x n, + space, + string ":", + space, + p_con env c] + | SgiStr (x, n, sgn) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] + | SgiSgn (x, n, sgn) => box [string "signature", + space, + p_named x n, + space, + string "=", + space, + p_sgn env sgn] + +and p_sgn env (sgn, loc) = + case sgn of + SgnConst sgis => box [string "sig", + newline, + let + val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) => + (p_sgn_item env sgi, + E.sgiBinds env sgi)) + env sgis + in + p_list_sep newline (fn x => x) psgis + end, + newline, + string "end"] + | SgnVar n => string ((#1 (E.lookupSgnNamed env n)) + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n) + | SgnFun (x, n, sgn, sgn') => box [string "functor", + space, + string "(", + p_named x n, + space, + string ":", + space, + p_sgn env sgn, + string ")", + space, + string ":", + space, + p_sgn (E.pushStrNamed env x n sgn) sgn'] + | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, + space, + string "where", + space, + string "con", + space, + p_list_sep (string ".") string (ms @ [x]), + space, + string "=", + space, + p_con env c] + | SgnProj (m1, ms, x) => + let + val (m1x, sgn) = E.lookupStrNamed env m1 + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) + + val m1s = if !debug then + m1x ^ "__" ^ Int.toString m1 + else + m1x + in + p_list_sep (string ".") string (m1x :: ms @ [x]) + end + +fun p_vali env (x, n, t, e) = box [p_named x n, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] + +fun p_decl env (dAll as (d, _) : decl) = + case d of + DCon (x, n, k, c) => box [string "con", + space, + p_named x n, + space, + string "::", + space, + p_kind env k, + space, + string "=", + space, + p_con env c] + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] + | DDatatypeImp (x, _, m1, ms, x', _, _) => + let + val m1x = #1 (E.lookupStrNamed env m1) + handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 + in + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (m1x :: ms @ [x'])] + end + | DVal vi => box [string "val", + space, + p_vali env vi] + | DValRec vis => + let + val env = E.declBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_vali env) vis] + end + + | DSgn (x, n, sgn) => box [string "signature", + space, + p_named x n, + space, + string "=", + space, + p_sgn env sgn] + | DStr (x, n, sgn, str) => box [string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn, + space, + string "=", + space, + p_str env str] + | DFfiStr (x, n, sgn) => box [string "extern", + space, + string "structure", + space, + p_named x n, + space, + string ":", + space, + p_sgn env sgn] + | DExport (_, sgn, str) => box [string "export", + space, + p_str env str, + space, + string ":", + space, + p_sgn env sgn] + | DTable (_, x, n, c, pe, _, ce, _) => box [string "table", + space, + p_named x n, + space, + string ":", + space, + p_con env c, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce] + | DSequence (_, x, n) => box [string "sequence", + space, + p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] + | DDatabase s => box [string "database", + space, + string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] + | DTask (e1, e2) => box [string "task", + space, + p_exp env e1, + space, + string "=", + space, + p_exp env e2] + | DPolicy e1 => box [string "policy", + space, + p_exp env e1] + | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" + +and p_str env (str, _) = + case str of + StrConst ds => box [string "struct", + newline, + p_file env ds, + newline, + string "end"] + | StrVar n => + let + val x = #1 (E.lookupStrNamed env n) + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n + + val s = if !debug then + x ^ "__" ^ Int.toString n + else + x + in + string s + end + | StrProj (str, s) => box [p_str env str, + string ".", + string s] + | StrFun (x, n, sgn, sgn', str) => + let + val env' = E.pushStrNamed env x n sgn + in + box [string "functor", + space, + string "(", + p_named x n, + space, + string ":", + space, + p_sgn env sgn, + string ")", + space, + string ":", + space, + p_sgn env' sgn', + space, + string "=>", + space, + p_str env' str] + end + | StrApp (str1, str2) => box [p_str env str1, + string "(", + p_str env str2, + string ")"] + +and p_file env file = + let + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) + env file + in + p_list_sep newline (fn x => x) pds + end + +end diff --git a/src/expl_rename.sig b/src/expl_rename.sig new file mode 100644 index 0000000..1aff315 --- /dev/null +++ b/src/expl_rename.sig @@ -0,0 +1,41 @@ +(* Copyright (c) 2014, 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. + *) + +(* To simplify Corify, it helps to apply a particular kind of renaming to functor + * bodies, so that nested functors refer only to fresh names. The payoff is that + * we can then implement applications of those nested functors by evaluating their + * bodies in arbitrary later contexts, even where identifiers defined in the + * outer functor body may have been shadowed. *) + +signature EXPL_RENAME = sig + + val rename : {NextId : int, + FormalName : string, + FormalId : int, + Body : Expl.str} -> int * Expl.str + +end diff --git a/src/expl_rename.sml b/src/expl_rename.sml new file mode 100644 index 0000000..bdcf1aa --- /dev/null +++ b/src/expl_rename.sml @@ -0,0 +1,454 @@ +(* Copyright (c) 2014, 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 ExplRename :> EXPL_RENAME = struct + +open Expl +structure E = ExplEnv + +structure IM = IntBinaryMap + +structure St :> sig + type t + + val create : int -> t + val next : t -> int + + val bind : t * int -> t * int + val lookup: t * int -> int option +end = struct + +type t = {next : int, + renaming : int IM.map} + +fun create next = {next = next, + renaming = IM.empty} + +fun next (t : t) = #next t + +fun bind ({next, renaming}, n) = + ({next = next + 1, + renaming = IM.insert (renaming, n, next)}, next) + +fun lookup ({next, renaming}, n) = + IM.find (renaming, n) + +end + +fun renameCon st (all as (c, loc)) = + case c of + TFun (c1, c2) => (TFun (renameCon st c1, renameCon st c2), loc) + | TCFun (x, k, c) => (TCFun (x, k, renameCon st c), loc) + | TRecord c => (TRecord (renameCon st c), loc) + | CRel _ => all + | CNamed n => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (CNamed n', loc)) + | CModProj (n, ms, x) => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (CModProj (n', ms, x), loc)) + | CApp (c1, c2) => (CApp (renameCon st c1, renameCon st c2), loc) + | CAbs (x, k, c) => (CAbs (x, k, renameCon st c), loc) + | CKAbs (x, c) => (CKAbs (x, renameCon st c), loc) + | CKApp (c, k) => (CKApp (renameCon st c, k), loc) + | TKFun (x, c) => (TKFun (x, renameCon st c), loc) + | CName _ => all + | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (renameCon st x, renameCon st c)) xcs), loc) + | CConcat (c1, c2) => (CConcat (renameCon st c1, renameCon st c2), loc) + | CMap _ => all + | CUnit => all + | CTuple cs => (CTuple (map (renameCon st) cs), loc) + | CProj (c, n) => (CProj (renameCon st c, n), loc) + +fun renamePatCon st pc = + case pc of + PConVar n => + (case St.lookup (st, n) of + NONE => pc + | SOME n' => PConVar n') + | PConProj (n, ms, x) => + (case St.lookup (st, n) of + NONE => pc + | SOME n' => PConProj (n', ms, x)) + +fun renamePat st (all as (p, loc)) = + case p of + PVar (x, c) => (PVar (x, renameCon st c), loc) + | PPrim _ => all + | PCon (dk, pc, cs, po) => (PCon (dk, renamePatCon st pc, + map (renameCon st) cs, + Option.map (renamePat st) po), loc) + | PRecord xpcs => (PRecord (map (fn (x, p, c) => + (x, renamePat st p, renameCon st c)) xpcs), loc) + +fun renameExp st (all as (e, loc)) = + case e of + EPrim _ => all + | ERel _ => all + | ENamed n => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (ENamed n', loc)) + | EModProj (n, ms, x) => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (EModProj (n', ms, x), loc)) + | EApp (e1, e2) => (EApp (renameExp st e1, renameExp st e2), loc) + | EAbs (x, dom, ran, e) => (EAbs (x, renameCon st dom, renameCon st ran, renameExp st e), loc) + | ECApp (e, c) => (ECApp (renameExp st e, renameCon st c), loc) + | ECAbs (x, k, e) => (ECAbs (x, k, renameExp st e), loc) + | EKAbs (x, e) => (EKAbs (x, renameExp st e), loc) + | EKApp (e, k) => (EKApp (renameExp st e, k), loc) + | ERecord xecs => (ERecord (map (fn (x, e, c) => (renameCon st x, + renameExp st e, + renameCon st c)) xecs), loc) + | EField (e, c, {field, rest}) => (EField (renameExp st e, + renameCon st c, + {field = renameCon st field, + rest = renameCon st rest}), loc) + | EConcat (e1, c1, e2, c2) => (EConcat (renameExp st e1, + renameCon st c1, + renameExp st e2, + renameCon st c2), loc) + | ECut (e, c, {field, rest}) => (ECut (renameExp st e, + renameCon st c, + {field = renameCon st field, + rest = renameCon st rest}), loc) + | ECutMulti (e, c, {rest}) => (ECutMulti (renameExp st e, + renameCon st c, + {rest = renameCon st rest}), loc) + | ECase (e, pes, {disc, result}) => (ECase (renameExp st e, + map (fn (p, e) => (renamePat st p, renameExp st e)) pes, + {disc = renameCon st disc, + result = renameCon st result}), loc) + | EWrite e => (EWrite (renameExp st e), loc) + | ELet (x, c1, e1, e2) => (ELet (x, renameCon st c1, + renameExp st e1, + renameExp st e2), loc) + +fun renameSitem st (all as (si, loc)) = + case si of + SgiConAbs _ => all + | SgiCon (x, n, k, c) => (SgiCon (x, n, k, renameCon st c), loc) + | SgiDatatype dts => (SgiDatatype (map (fn (x, n, xs, cns) => + (x, n, xs, + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns)) dts), + loc) + | SgiDatatypeImp (x, n, n', xs, x', xs', cns) => + (SgiDatatypeImp (x, n, n', xs, x', xs', + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns), loc) + | SgiVal (x, n, c) => (SgiVal (x, n, renameCon st c), loc) + | SgiSgn (x, n, sg) => (SgiSgn (x, n, renameSgn st sg), loc) + | SgiStr (x, n, sg) => (SgiStr (x, n, renameSgn st sg), loc) + +and renameSgn st (all as (sg, loc)) = + case sg of + SgnConst sis => (SgnConst (map (renameSitem st) sis), loc) + | SgnVar n => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (SgnVar n', loc)) + | SgnFun (x, n, dom, ran) => (SgnFun (x, n, renameSgn st dom, renameSgn st ran), loc) + | SgnWhere (sg, xs, s, c) => (SgnWhere (renameSgn st sg, xs, s, renameCon st c), loc) + | SgnProj (n, ms, x) => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (SgnProj (n', ms, x), loc)) + +fun renameDecl st (all as (d, loc)) = + case d of + DCon (x, n, k, c) => (DCon (x, n, k, renameCon st c), loc) + | DDatatype dts => (DDatatype (map (fn (x, n, xs, cns) => + (x, n, xs, + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns)) dts), + loc) + | DDatatypeImp (x, n, n', xs, x', xs', cns) => + (DDatatypeImp (x, n, n', xs, x', xs', + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns), loc) + | DVal (x, n, c, e) => (DVal (x, n, renameCon st c, renameExp st e), loc) + | DValRec vis => (DValRec (map (fn (x, n, c, e) => (x, n, renameCon st c, renameExp st e)) vis), loc) + | DSgn (x, n, sg) => (DSgn (x, n, renameSgn st sg), loc) + | DStr (x, n, sg, str) => (DStr (x, n, renameSgn st sg, renameStr st str), loc) + | DFfiStr (x, n, sg) => (DFfiStr (x, n, renameSgn st sg), loc) + | DExport (n, sg, str) => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (DExport (n', renameSgn st sg, renameStr st str), loc)) + | DTable (n, x, m, c1, e1, c2, e2, c3) => + (DTable (n, x, m, renameCon st c1, renameExp st e1, renameCon st c2, + renameExp st e2, renameCon st c3), loc) + | DSequence _ => all + | DView (n, x, n', e, c) => (DView (n, x, n', renameExp st e, renameCon st c), loc) + | DDatabase _ => all + | DCookie (n, x, n', c) => (DCookie (n, x, n', renameCon st c), loc) + | DStyle _ => all + | DTask (e1, e2) => (DTask (renameExp st e1, renameExp st e2), loc) + | DPolicy e => (DPolicy (renameExp st e), loc) + | DOnError (n, xs, x) => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (DOnError (n', xs, x), loc)) + | DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc) + +and renameStr st (all as (str, loc)) = + case str of + StrConst ds => (StrConst (map (renameDecl st) ds), loc) + | StrVar n => + (case St.lookup (st, n) of + NONE => all + | SOME n' => (StrVar n', loc)) + | StrProj (str, x) => (StrProj (renameStr st str, x), loc) + | StrFun (x, n, dom, ran, str) => (StrFun (x, n, renameSgn st dom, + renameSgn st ran, + renameStr st str), loc) + | StrApp (str1, str2) => (StrApp (renameStr st str1, renameStr st str2), loc) + + + +fun fromArity (n, loc) = + case n of + 0 => (KType, loc) + | _ => (KArrow ((KType, loc), fromArity (n - 1, loc)), loc) + +fun dupDecl (all as (d, loc), st) = + case d of + DCon (x, n, k, c) => + let + val (st, n') = St.bind (st, n) + in + ([(DCon (x, n, k, renameCon st c), loc), + (DCon (x, n', k, (CNamed n, loc)), loc)], + st) + end + | DDatatype dts => + let + val d = (DDatatype (map (fn (x, n, xs, cns) => + (x, n, xs, + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns)) dts), + loc) + + val (dts', st) = ListUtil.foldlMap (fn ((x, n, xs, cns), st) => + let + val (st, n') = St.bind (st, n) + + val (cns', st) = ListUtil.foldlMap + (fn ((x, n, _), st) => + let + val (st, n') = + St.bind (st, n) + in + ((x, n, n'), st) + end) st cns + in + ((x, n, length xs, n', cns'), st) + end) st dts + + val env = E.declBinds E.empty d + in + (d + :: map (fn (x, n, arity, n', _) => + (DCon (x, n', fromArity (arity, loc), (CNamed n, loc)), loc)) dts' + @ ListUtil.mapConcat (fn (_, _, _, _, cns') => + map (fn (x, n, n') => + (DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)), + loc)) cns') dts', + st) + end + | DDatatypeImp (x, n, n', xs, x', xs', cns) => + let + val d = (DDatatypeImp (x, n, n', xs, x', xs', + map (fn (x, n, co) => + (x, n, Option.map (renameCon st) co)) cns), loc) + + val (cns', st) = ListUtil.foldlMap + (fn ((x, n, _), st) => + let + val (st, n') = + St.bind (st, n) + in + ((x, n, n'), st) + end) st cns + + val (st, n') = St.bind (st, n) + + val env = E.declBinds E.empty d + in + (d + :: (DCon (x, n', fromArity (length xs, loc), (CNamed n, loc)), loc) + :: map (fn (x, n, n') => + (DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)), + loc)) cns', + st) + end + | DVal (x, n, c, e) => + let + val (st, n') = St.bind (st, n) + val c' = renameCon st c + in + ([(DVal (x, n, c', renameExp st e), loc), + (DVal (x, n', c', (ENamed n, loc)), loc)], + st) + end + | DValRec vis => + let + val d = (DValRec (map (fn (x, n, c, e) => (x, n, renameCon st c, renameExp st e)) vis), loc) + + val (vis', st) = ListUtil.foldlMap (fn ((x, n, _, _), st) => + let + val (st, n') = St.bind (st, n) + in + ((x, n, n'), st) + end) st vis + + val env = E.declBinds E.empty d + in + (d + :: map (fn (x, n, n') => (DVal (x, n', #2 (E.lookupENamed env n), (ENamed n, loc)), loc)) vis', + st) + end + | DSgn (x, n, sg) => + let + val (st, n') = St.bind (st, n) + in + ([(DSgn (x, n, renameSgn st sg), loc), + (DSgn (x, n', (SgnVar n, loc)), loc)], + st) + end + | DStr (x, n, sg, str) => + let + val (st, n') = St.bind (st, n) + val sg' = renameSgn st sg + in + ([(DStr (x, n, sg', renameStr st str), loc), + (DStr (x, n', sg', (StrVar n, loc)), loc)], + st) + end + | DFfiStr (x, n, sg) => ([(DFfiStr (x, n, renameSgn st sg), loc)], st) + | DExport (n, sg, str) => + (case St.lookup (st, n) of + NONE => ([all], st) + | SOME n' => ([(DExport (n', renameSgn st sg, renameStr st str), loc)], st)) + | DTable (n, x, m, c1, e1, c2, e2, c3) => + let + val (st, m') = St.bind (st, m) + + val d = (DTable (n, x, m, renameCon st c1, renameExp st e1, renameCon st c2, + renameExp st e2, renameCon st c3), loc) + + val env = E.declBinds E.empty d + in + ([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st) + end + | DSequence (n, x, m) => + let + val (st, m') = St.bind (st, m) + + val env = E.declBinds E.empty all + in + ([all, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st) + end + | DView (n, x, m, e, c) => + let + val (st, m') = St.bind (st, m) + + val d = (DView (n, x, m, renameExp st e, renameCon st c), loc) + + val env = E.declBinds E.empty d + in + ([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st) + end + | DDatabase _ => ([all], st) + | DCookie (n, x, m, c) => + let + val (st, m') = St.bind (st, m) + + val d = (DCookie (n, x, m, renameCon st c), loc) + + val env = E.declBinds E.empty d + in + ([d, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st) + end + | DStyle (n, x, m) => + let + val (st, m') = St.bind (st, m) + + val env = E.declBinds E.empty all + in + ([all, (DVal (x, m', #2 (E.lookupENamed env m), (ENamed m, loc)), loc)], st) + end + | DTask (e1, e2) => ([(DTask (renameExp st e1, renameExp st e2), loc)], st) + | DPolicy e => ([(DPolicy (renameExp st e), loc)], st) + | DOnError (n, xs, x) => + (case St.lookup (st, n) of + NONE => ([all], st) + | SOME n' => ([(DOnError (n', xs, x), loc)], st)) + | DFfi (x, n, modes, t) => + let + val (st, n') = St.bind (st, n) + val t' = renameCon st t + in + ([(DFfi (x, n, modes, t'), loc), + (DVal (x, n', t', (ENamed n, loc)), loc)], + st) + end + +fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} = + case str of + StrConst ds => + let + val st = St.create NextId + val (st, n) = St.bind (st, FormalId) + + val (ds, st) = ListUtil.foldlMapConcat dupDecl st ds + + (* Revenge of the functor parameter renamer! + * See comment in elaborate.sml for the start of the saga. + * We need to alpha-rename the argument to allow sufficient shadowing in the body. *) + + fun mungeName m = + if List.exists (fn (DStr (x, _, _, _), _) => x = m + | _ => false) ds then + mungeName ("?" ^ m) + else + m + + val FormalName = mungeName FormalName + + val ds = (DStr (FormalName, n, (SgnConst [], loc), (StrVar FormalId, loc)), loc) :: ds + in + (St.next st, (StrConst ds, loc)) + end + | _ => (NextId, all) + +end diff --git a/src/expl_util.sig b/src/expl_util.sig new file mode 100644 index 0000000..3e5c333 --- /dev/null +++ b/src/expl_util.sig @@ -0,0 +1,119 @@ +(* Copyright (c) 2008, 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 EXPL_UTIL = sig + +structure Kind : sig + val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB, + bind : 'context * string -> 'context} + -> ('context, Expl.kind, 'state, 'abort) Search.mapfolderB + val mapfold : (Expl.kind', 'state, 'abort) Search.mapfolder + -> (Expl.kind, 'state, 'abort) Search.mapfolder + val exists : (Expl.kind' -> bool) -> Expl.kind -> bool + val mapB : {kind : 'context -> Expl.kind' -> Expl.kind', + bind : 'context * string -> 'context} + -> 'context -> (Expl.kind -> Expl.kind) +end + +structure Con : sig + datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + + val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Expl.con, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder, + con : (Expl.con', 'state, 'abort) Search.mapfolder} + -> (Expl.con, 'state, 'abort) Search.mapfolder + + val mapB : {kind : 'context -> Expl.kind' -> Expl.kind', + con : 'context -> Expl.con' -> Expl.con', + bind : 'context * binder -> 'context} + -> 'context -> (Expl.con -> Expl.con) + val map : {kind : Expl.kind' -> Expl.kind', + con : Expl.con' -> Expl.con'} + -> Expl.con -> Expl.con + val exists : {kind : Expl.kind' -> bool, + con : Expl.con' -> bool} -> Expl.con -> bool +end + +structure Exp : sig + datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + | RelE of string * Expl.con + | NamedE of string * Expl.con + + val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB, + exp : ('context, Expl.exp', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Expl.exp, 'state, 'abort) Search.mapfolderB + val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder, + con : (Expl.con', 'state, 'abort) Search.mapfolder, + exp : (Expl.exp', 'state, 'abort) Search.mapfolder} + -> (Expl.exp, 'state, 'abort) Search.mapfolder + val exists : {kind : Expl.kind' -> bool, + con : Expl.con' -> bool, + exp : Expl.exp' -> bool} -> Expl.exp -> bool +end + +structure Sgn : sig + datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + | Sgn of string * Expl.sgn + | Str of string * Expl.sgn + + val mapfoldB : {kind : ('context, Expl.kind', 'state, 'abort) Search.mapfolderB, + con : ('context, Expl.con', 'state, 'abort) Search.mapfolderB, + sgn_item : ('context, Expl.sgn_item', 'state, 'abort) Search.mapfolderB, + sgn : ('context, Expl.sgn', 'state, 'abort) Search.mapfolderB, + bind : 'context * binder -> 'context} + -> ('context, Expl.sgn, 'state, 'abort) Search.mapfolderB + + + val mapfold : {kind : (Expl.kind', 'state, 'abort) Search.mapfolder, + con : (Expl.con', 'state, 'abort) Search.mapfolder, + sgn_item : (Expl.sgn_item', 'state, 'abort) Search.mapfolder, + sgn : (Expl.sgn', 'state, 'abort) Search.mapfolder} + -> (Expl.sgn, 'state, 'abort) Search.mapfolder + + val map : {kind : Expl.kind' -> Expl.kind', + con : Expl.con' -> Expl.con', + sgn_item : Expl.sgn_item' -> Expl.sgn_item', + sgn : Expl.sgn' -> Expl.sgn'} + -> Expl.sgn -> Expl.sgn + +end + +end diff --git a/src/expl_util.sml b/src/expl_util.sml new file mode 100644 index 0000000..ff55823 --- /dev/null +++ b/src/expl_util.sml @@ -0,0 +1,557 @@ +(* Copyright (c) 2008, 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 ExplUtil :> EXPL_UTIL = struct + +open Expl + +structure S = Search + +structure Kind = struct + +fun mapfoldB {kind, bind} = + let + fun mfk ctx k acc = + S.bindP (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)) + + | KRel _ => S.return2 kAll + | KFun (x, k) => + S.map2 (mfk (bind (ctx, x)) k, + fn k' => + (KFun (x, k'), loc)) + in + mfk + end + +fun mapfold fk = + mapfoldB {kind = fn () => fk, + bind = fn ((), _) => ()} () + +fun mapB {kind, bind} ctx k = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + bind = bind} ctx k () of + S.Continue (k, ()) => k + | S.Return _ => raise Fail "ExplUtil.Kind.mapB: Impossible" + +fun exists f k = + case mapfold (fn k => fn () => + if f k then + S.Return () + else + S.Continue (k, ())) k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure Con = struct + +datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + +fun mapfoldB {kind = fk, con = fc, bind} = + let + val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)} + + fun mfc ctx c acc = + S.bindP (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 (x, k, c) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfc (bind (ctx, RelC (x, k))) c, + fn c' => + (TCFun (x, k', c'), 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)) + + | 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 + +fun mapfold {kind = fk, con = fc} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + bind = fn ((), _) => ()} () + +fun mapB {kind, con, bind} ctx c = + case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()), + con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()), + bind = bind} ctx c () of + S.Continue (c, ()) => c + | S.Return _ => raise Fail "ExplUtil.Con.mapB: Impossible" + +fun map {kind, con} s = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ())} s () of + S.Return () => raise Fail "ExplUtil.Con.map: Impossible" + | S.Continue (s, ()) => s + +fun exists {kind, con} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ())} k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure Exp = struct + +datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + | RelE of string * Expl.con + | NamedE of string * Expl.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 mfe ctx e acc = + S.bindP (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 (x, k, e) => + S.bind2 (mfk ctx k, + fn k' => + S.map2 (mfe (bind (ctx, RelC (x, k))) e, + fn e' => + (ECAbs (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)))) + + | EWrite e => + S.map2 (mfe ctx e, + fn e' => + (EWrite e', loc)) + + | ECase (e, pes, {disc, result}) => + S.bind2 (mfe ctx e, + fn e' => + S.bind2 (ListUtil.mapfold (fn (p, e) => + S.map2 (mfe ctx e, + fn e' => (p, e'))) 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))))) + + | ELet (x, t, e1, e2) => + S.bind2 (mfc ctx t, + fn t' => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe (bind (ctx, RelE (x, t))) e2, + fn e2' => + (ELet (x, t', e1', e2'), loc)))) + + | 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))) + in + mfe + end + +fun mapfold {kind = fk, con = fc, exp = fe} = + mapfoldB {kind = fn () => fk, + con = fn () => fc, + exp = fn () => fe, + bind = fn ((), _) => ()} () + +fun exists {kind, con, exp} k = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ())} k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure Sgn = struct + +datatype binder = + RelK of string + | RelC of string * Expl.kind + | NamedC of string * Expl.kind + | Str of string * Expl.sgn + | Sgn of string * Expl.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.bindP (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 (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiStr (x, n, s'), loc)) + | SgiSgn (x, n, s) => + S.map2 (sg ctx s, + fn s' => + (SgiSgn (x, n, s'), loc)) + + and sg ctx s acc = + S.bindP (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, _, k) => + bind (ctx, NamedC (x, k)) + | SgiCon (x, _, k, _) => + bind (ctx, NamedC (x, k)) + | SgiDatatype dts => + foldl (fn ((x, _, ks, _), ctx) => + let + val k' = (KType, loc) + val k = foldl (fn (_, k) => (KArrow (k', k), loc)) + k' ks + in + bind (ctx, NamedC (x, k)) + end) ctx dts + | SgiDatatypeImp (x, _, _, _, _, _, _) => + bind (ctx, NamedC (x, (KType, loc))) + | SgiVal _ => ctx + | SgiStr (x, _, sgn) => + bind (ctx, Str (x, sgn)) + | SgiSgn (x, _, sgn) => + bind (ctx, Sgn (x, sgn)), + 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, s1'))) s2, + fn s2' => + (SgnFun (m, n, s1', s2'), loc))) + | 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))) + | SgnProj _ => S.return2 sAll + in + sg + end + +fun mapfold {kind, con, sgn_item, sgn} = + mapfoldB {kind = fn () => kind, + con = fn () => con, + sgn_item = fn () => sgn_item, + sgn = fn () => sgn, + bind = fn ((), _) => ()} () + +fun map {kind, con, sgn_item, sgn} s = + case mapfold {kind = fn k => fn () => S.Continue (kind k, ()), + con = fn c => fn () => S.Continue (con c, ()), + sgn_item = fn si => fn () => S.Continue (sgn_item si, ()), + sgn = fn s => fn () => S.Continue (sgn s, ())} s () of + S.Return () => raise Fail "Expl_util.Sgn.map" + | S.Continue (s, ()) => s + +end + +end diff --git a/src/explify.sig b/src/explify.sig new file mode 100644 index 0000000..f839b3e --- /dev/null +++ b/src/explify.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 EXPLIFY = sig + + val explify : Elab.file -> Expl.file + +end diff --git a/src/explify.sml b/src/explify.sml new file mode 100644 index 0000000..e2a317a --- /dev/null +++ b/src/explify.sml @@ -0,0 +1,213 @@ +(* 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 Explify :> EXPLIFY = struct + +structure EM = ErrorMsg +structure L = Elab +structure L' = Expl + +fun explifyKind (k, loc) = + case k of + L.KType => (L'.KType, loc) + | L.KArrow (k1, k2) => (L'.KArrow (explifyKind k1, explifyKind k2), loc) + | L.KName => (L'.KName, loc) + | L.KRecord k => (L'.KRecord (explifyKind k), loc) + + | L.KUnit => (L'.KUnit, loc) + | L.KTuple ks => (L'.KTuple (map explifyKind ks), loc) + + | L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc) + | L.KUnif (_, _, ref (L.KKnown k)) => explifyKind k + | L.KUnif _ => raise Fail ("explifyKind: KUnif at " ^ EM.spanToString loc) + | L.KTupleUnif (loc, _, ref (L.KKnown k)) => explifyKind k + | L.KTupleUnif _ => raise Fail ("explifyKind: KTupleUnif at " ^ EM.spanToString loc) + + | L.KRel n => (L'.KRel n, loc) + | L.KFun (x, k) => (L'.KFun (x, explifyKind k), loc) + +fun explifyCon (c, loc) = + case c of + L.TFun (t1, t2) => (L'.TFun (explifyCon t1, explifyCon t2), loc) + | L.TCFun (_, x, k, t) => (L'.TCFun (x, explifyKind k, explifyCon t), loc) + | L.TDisjoint (_, _, t) => explifyCon t + | L.TRecord c => (L'.TRecord (explifyCon c), loc) + + | L.CRel n => (L'.CRel n, loc) + | L.CNamed n => (L'.CNamed n, loc) + | L.CModProj (m, ms, x) => (L'.CModProj (m, ms, x), loc) + + | L.CApp (c1, c2) => (L'.CApp (explifyCon c1, explifyCon c2), loc) + | L.CAbs (x, k, c) => (L'.CAbs (x, explifyKind k, explifyCon c), loc) + + | L.CName s => (L'.CName s, loc) + + | L.CRecord (k, xcs) => (L'.CRecord (explifyKind k, map (fn (c1, c2) => (explifyCon c1, explifyCon c2)) xcs), loc) + | L.CConcat (c1, c2) => (L'.CConcat (explifyCon c1, explifyCon c2), loc) + | L.CMap (dom, ran) => (L'.CMap (explifyKind dom, explifyKind ran), loc) + + | L.CUnit => (L'.CUnit, loc) + + | L.CTuple cs => (L'.CTuple (map explifyCon cs), loc) + | L.CProj (c, n) => (L'.CProj (explifyCon c, n), loc) + + | L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc) + | L.CUnif (nl, _, _, _, ref (L.Known c)) => explifyCon (ElabEnv.mliftConInCon nl c) + | L.CUnif _ => raise Fail ("explifyCon: CUnif at " ^ EM.spanToString loc) + + | L.CKAbs (x, c) => (L'.CKAbs (x, explifyCon c), loc) + | L.CKApp (c, k) => (L'.CKApp (explifyCon c, explifyKind k), loc) + | L.TKFun (x, c) => (L'.TKFun (x, explifyCon c), loc) + +fun explifyPatCon pc = + case pc of + L.PConVar n => L'.PConVar n + | L.PConProj x => L'.PConProj x + +fun explifyPat (p, loc) = + case p of + L.PVar (x, t) => (L'.PVar (x, explifyCon t), loc) + | L.PPrim p => (L'.PPrim p, loc) + | L.PCon (dk, pc, cs, po) => (L'.PCon (dk, explifyPatCon pc, map explifyCon cs, Option.map explifyPat po), loc) + | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, explifyPat p, explifyCon t)) xps), loc) + +fun explifyExp (e, loc) = + case e of + L.EPrim p => (L'.EPrim p, loc) + | L.ERel n => (L'.ERel n, loc) + | L.ENamed n => (L'.ENamed n, loc) + | L.EModProj (m, ms, x) => (L'.EModProj (m, ms, x), loc) + | L.EApp (e1, e2) => (L'.EApp (explifyExp e1, explifyExp e2), loc) + | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, explifyCon dom, explifyCon ran, explifyExp e1), loc) + | L.ECApp (e1, c) => (L'.ECApp (explifyExp e1, explifyCon c), loc) + | L.ECAbs (_, x, k, e1) => (L'.ECAbs (x, explifyKind k, explifyExp e1), loc) + + | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (explifyCon c, explifyExp e, explifyCon t)) xes), loc) + | L.EField (e1, c, {field, rest}) => (L'.EField (explifyExp e1, explifyCon c, + {field = explifyCon field, rest = explifyCon rest}), loc) + | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (explifyExp e1, explifyCon c1, explifyExp e2, explifyCon c2), + loc) + | L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c, + {field = explifyCon field, rest = explifyCon rest}), loc) + | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c, + {rest = explifyCon rest}), loc) + | L.ECase (e, pes, {disc, result}) => + (L'.ECase (explifyExp e, + map (fn (p, e) => (explifyPat p, explifyExp e)) pes, + {disc = explifyCon disc, result = explifyCon result}), loc) + + | L.EError => raise Fail ("explifyExp: EError at " ^ EM.spanToString loc) + | L.EUnif (ref (SOME e)) => explifyExp e + | L.EUnif _ => raise Fail ("explifyExp: Undetermined EUnif at " ^ EM.spanToString loc) + + | L.ELet (des, e, t) => + foldr (fn ((de, loc), e) => + case de of + L.EDValRec _ => raise Fail "explifyExp: Local 'val rec' remains" + | L.EDVal ((L.PVar (x, _), _), t', e') => (L'.ELet (x, explifyCon t', explifyExp e', e), loc) + | L.EDVal (p, t', e') => (L'.ECase (explifyExp e', + [(explifyPat p, e)], + {disc = explifyCon t', result = explifyCon t}), loc)) + (explifyExp e) des + + | L.EKAbs (x, e) => (L'.EKAbs (x, explifyExp e), loc) + | L.EKApp (e, k) => (L'.EKApp (explifyExp e, explifyKind k), loc) + +fun explifySgi (sgi, loc) = + case sgi of + L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc) + | L.SgiCon (x, n, k, c) => SOME (L'.SgiCon (x, n, explifyKind k, explifyCon c), loc) + | L.SgiDatatype dts => SOME (L'.SgiDatatype (map (fn (x, n, xs, xncs) => + (x, n, xs, + map (fn (x, n, co) => + (x, n, Option.map explifyCon co)) xncs)) dts), loc) + | L.SgiDatatypeImp (x, n, m1, ms, s, xs, xncs) => + SOME (L'.SgiDatatypeImp (x, n, m1, ms, s, xs, map (fn (x, n, co) => + (x, n, Option.map explifyCon co)) xncs), loc) + | L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc) + | L.SgiStr (_, x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) + | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) + | L.SgiConstraint _ => NONE + | L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc) + | L.SgiClass (x, n, k, c) => SOME (L'.SgiCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), + explifyCon c), loc) + +and explifySgn (sgn, loc) = + case sgn of + L.SgnConst sgis => (L'.SgnConst (List.mapPartial explifySgi sgis), loc) + | L.SgnVar n => (L'.SgnVar n, loc) + | L.SgnFun (m, n, dom, ran) => (L'.SgnFun (m, n, explifySgn dom, explifySgn ran), loc) + | L.SgnWhere (sgn, ms, x, c) => (L'.SgnWhere (explifySgn sgn, ms, x, explifyCon c), loc) + | L.SgnProj x => (L'.SgnProj x, loc) + | L.SgnError => raise Fail ("explifySgn: SgnError at " ^ EM.spanToString loc) + +fun explifyDecl (d, loc : EM.span) = + case d of + L.DCon (x, n, k, c) => SOME (L'.DCon (x, n, explifyKind k, explifyCon c), loc) + | L.DDatatype dts => SOME (L'.DDatatype (map (fn (x, n, xs, xncs) => + (x, n, xs, + map (fn (x, n, co) => + (x, n, Option.map explifyCon co)) xncs)) dts), loc) + | L.DDatatypeImp (x, n, m1, ms, s, xs, xncs) => + SOME (L'.DDatatypeImp (x, n, m1, ms, s, xs, + map (fn (x, n, co) => + (x, n, Option.map explifyCon co)) xncs), loc) + | L.DVal (x, n, t, e) => SOME (L'.DVal (x, n, explifyCon t, explifyExp e), loc) + | L.DValRec vis => SOME (L'.DValRec (map (fn (x, n, t, e) => (x, n, explifyCon t, explifyExp e)) vis), loc) + + | L.DSgn (x, n, sgn) => SOME (L'.DSgn (x, n, explifySgn sgn), loc) + | L.DStr (x, n, sgn, str) => SOME (L'.DStr (x, n, explifySgn sgn, explifyStr str), loc) + | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc) + | L.DConstraint (c1, c2) => NONE + | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) + | L.DTable (nt, x, n, c, pe, pc, ce, cc) => + SOME (L'.DTable (nt, x, n, explifyCon c, + explifyExp pe, explifyCon pc, + explifyExp ce, explifyCon cc), loc) + | L.DView (nt, x, n, e, c) => + SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc) + | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) + | L.DDatabase s => SOME (L'.DDatabase s, loc) + | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) + | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) + | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc) + | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc) + | L.DOnError v => SOME (L'.DOnError v, loc) + | L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc) + +and explifyStr (str, loc) = + case str of + L.StrConst ds => (L'.StrConst (List.mapPartial explifyDecl ds), loc) + | L.StrVar n => (L'.StrVar n, loc) + | L.StrProj (str, s) => (L'.StrProj (explifyStr str, s), loc) + | L.StrFun (m, n, dom, ran, str) => (L'.StrFun (m, n, explifySgn dom, explifySgn ran, explifyStr str), loc) + | L.StrApp (str1, str2) => (L'.StrApp (explifyStr str1, explifyStr str2), loc) + | L.StrError => raise Fail ("explifyStr: StrError at " ^ EM.spanToString loc) + +val explify = List.mapPartial explifyDecl + +end diff --git a/src/export.sig b/src/export.sig new file mode 100644 index 0000000..881459c --- /dev/null +++ b/src/export.sig @@ -0,0 +1,44 @@ +(* Copyright (c) 2009, 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 EXPORT = sig + +datatype effect = + ReadOnly + | ReadCookieWrite + | ReadWrite + +datatype export_kind = + Link of effect + | Action of effect + | Rpc of effect + | Extern of effect + +val p_effect : effect Print.printer +val p_export_kind : export_kind Print.printer + +end diff --git a/src/export.sml b/src/export.sml new file mode 100644 index 0000000..a99d0b7 --- /dev/null +++ b/src/export.sml @@ -0,0 +1,57 @@ +(* Copyright (c) 2009, 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 Export :> EXPORT = struct + +open Print.PD +open Print + +datatype effect = + ReadOnly + | ReadCookieWrite + | ReadWrite + +datatype export_kind = + Link of effect + | Action of effect + | Rpc of effect + | Extern of effect + +fun p_effect ef = + case ef of + ReadOnly => string "r" + | ReadCookieWrite => string "rcw" + | ReadWrite => string "rw" + +fun p_export_kind ck = + case ck of + Link ef => box [string "link(", p_effect ef, string ")"] + | Action ef => box [string "action(", p_effect ef, string ")"] + | Rpc ef => box [string "rpc(", p_effect ef, string ")"] + | Extern ef => box [string "extern(", p_effect ef, string ")"] + +end diff --git a/src/fastcgi.sig b/src/fastcgi.sig new file mode 100644 index 0000000..c37fe68 --- /dev/null +++ b/src/fastcgi.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 FASTCGI = sig + +end diff --git a/src/fastcgi.sml b/src/fastcgi.sml new file mode 100644 index 0000000..bf2a2a1 --- /dev/null +++ b/src/fastcgi.sml @@ -0,0 +1,53 @@ +(* 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 Fastcgi :> FASTCGI = struct + +open Settings +open Print.PD Print + +val () = addProtocol {name = "fastcgi", + compile = "", + linkStatic = "liburweb_fastcgi.a", + linkDynamic = "-lurweb_fastcgi", + persistent = true, + code = fn () => box [string "void uw_global_custom() {", + newline, + case getSigFile () of + NONE => box [] + | SOME sf => box [string "extern char *uw_sig_file;", + newline, + string "uw_sig_file = \"", + string sf, + string "\";", + newline], + string "uw_setup_limits();", + newline, + string "}", + newline]} + +end diff --git a/src/fileio.sig b/src/fileio.sig new file mode 100644 index 0000000..37b3b52 --- /dev/null +++ b/src/fileio.sig @@ -0,0 +1,9 @@ +signature FILE_IO = sig + + (* When was a source file last modified (excluding files produced after [getResetTime])? *) + val mostRecentModTime : unit -> Time.time + + val txtOpenIn : string -> TextIO.instream + val binOpenIn : string -> BinIO.instream + +end diff --git a/src/fileio.sml b/src/fileio.sml new file mode 100644 index 0000000..cab9d8a --- /dev/null +++ b/src/fileio.sml @@ -0,0 +1,39 @@ +structure FileIO :> FILE_IO = struct + +val mostRecentModTimeRef = ref (Time.zeroTime) + +fun checkFileModTime fname = + let + val mtime = OS.FileSys.modTime fname + val mostRecentMod = !mostRecentModTimeRef + val resetTime = Globals.getResetTime () + fun lessThan (a, b) = LargeInt.compare (Time.toSeconds a, Time.toSeconds b) = LESS + infix lessThan + in + if mostRecentMod lessThan mtime andalso mtime lessThan resetTime + then mostRecentModTimeRef := mtime + else () + end + +fun mostRecentModTime () = + if Time.compare (!mostRecentModTimeRef, Time.zeroTime) = EQUAL + then Globals.getResetTime () + else !mostRecentModTimeRef + +fun txtOpenIn fname = + let + val inf = TextIO.openIn fname + val () = checkFileModTime fname + in + inf + end + +fun binOpenIn fname = + let + val inf = BinIO.openIn fname + val () = checkFileModTime fname + in + inf + end + +end diff --git a/src/fuse.sig b/src/fuse.sig new file mode 100644 index 0000000..3ad45ac --- /dev/null +++ b/src/fuse.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 FUSE = sig + + val fuse : Mono.file -> Mono.file + +end diff --git a/src/fuse.sml b/src/fuse.sml new file mode 100644 index 0000000..5193e59 --- /dev/null +++ b/src/fuse.sml @@ -0,0 +1,152 @@ +(* Copyright (c) 2008, 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 Fuse :> FUSE = struct + +open Mono +structure U = MonoUtil + +structure IM = IntBinaryMap + +fun returnsString (t, loc) = + let + fun rs (t, loc) = + case t of + TFfi ("Basis", "string") => SOME ([], (TRecord [], loc)) + | TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + in + case t of + TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + end + +fun fuse file = + let + fun doDecl (d as (_, loc), (funcs, maxName)) = + let + exception GetBody + + fun doVi ((x, n, t, e, s), funcs, maxName) = + case returnsString t of + NONE => (NONE, funcs, maxName) + | SOME (args, t') => + let + fun getBody (e, args) = + case (#1 e, args) of + (_, []) => (e, []) + | (EAbs (x, t, _, e), _ :: args) => + let + val (body, args') = getBody (e, args) + in + (body, (x, t) :: args') + end + | _ => raise GetBody + + val (body, args) = getBody (e, args) + val body = MonoOpt.optExp (EWrite body, loc) + val (body, _) = foldr (fn ((x, dom), (body, ran)) => + ((EAbs (x, dom, ran, body), loc), + (TFun (dom, ran), loc))) + (body, (TRecord [], loc)) args + in + (SOME (x, maxName, t', body, s), + IM.insert (funcs, n, maxName), + maxName + 1) + end + handle GetBody => (NONE, funcs, maxName) + + val (d, funcs, maxName) = + case #1 d of + DVal vi => + let + val (vi', funcs, maxName) = doVi (vi, funcs, maxName) + in + (case vi' of + NONE => d + | SOME vi' => (DValRec [vi, vi'], loc), + funcs, maxName) + end + | DValRec vis => + let + val (vis', funcs, maxName) = + foldl (fn (vi, (vis', funcs, maxName)) => + let + val (vi', funcs, maxName) = doVi (vi, funcs, maxName) + in + (case vi' of + NONE => vis' + | SOME vi' => vi' :: vis', + funcs, maxName) + end) + ([], funcs, maxName) vis + in + ((DValRec (vis @ vis'), loc), funcs, maxName) + end + | _ => (d, funcs, maxName) + + fun exp e = + case e of + EWrite e' => + let + fun unravel (e, loc) = + case e of + ENamed n => + (case IM.find (funcs, n) of + NONE => NONE + | SOME n' => SOME (ENamed n', loc)) + | EApp (e1, e2) => + (case unravel e1 of + NONE => NONE + | SOME e1 => SOME (EApp (e1, e2), loc)) + | _ => NONE + in + case unravel e' of + NONE => e + | SOME (e', _) => e' + end + | _ => e + in + (U.Decl.map {typ = fn x => x, + exp = exp, + decl = fn x => x} + d, + (funcs, maxName)) + end + + val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file) + in + (ds, #2 file) + end + +end diff --git a/src/globals.sig b/src/globals.sig new file mode 100644 index 0000000..0cff65b --- /dev/null +++ b/src/globals.sig @@ -0,0 +1,7 @@ +signature GLOBALS = sig + + (* When was the Ur/Web compiler started or reset? *) + val setResetTime : unit -> unit + val getResetTime : unit -> Time.time + +end diff --git a/src/globals.sml b/src/globals.sml new file mode 100644 index 0000000..fafc043 --- /dev/null +++ b/src/globals.sml @@ -0,0 +1,7 @@ +structure Globals :> GLOBALS = struct + +val resetTime = ref (Time.zeroTime) +fun setResetTime () = resetTime := Time.now () +fun getResetTime () = !resetTime + +end diff --git a/src/http.sig b/src/http.sig new file mode 100644 index 0000000..a9c13e8 --- /dev/null +++ b/src/http.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 HTTP = sig + +end diff --git a/src/http.sml b/src/http.sml new file mode 100644 index 0000000..64dbb06 --- /dev/null +++ b/src/http.sml @@ -0,0 +1,55 @@ +(* 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 Http :> HTTP = struct + +open Settings +open Print.PD Print + +val () = addProtocol {name = "http", + compile = "", + linkStatic = "liburweb_http.a", + linkDynamic = "-lurweb_http", + persistent = true, + code = fn () => box [string "void uw_global_custom() {", + newline, + case getSigFile () of + NONE => box [] + | SOME sf => box [string "extern char *uw_sig_file;", + newline, + string "uw_sig_file = \"", + string sf, + string "\";", + newline], + string "uw_setup_limits();", + newline, + string "}", + newline]} + +val () = setProtocol "http" + +end diff --git a/src/iflow.sig b/src/iflow.sig new file mode 100644 index 0000000..3e624bb --- /dev/null +++ b/src/iflow.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 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. + *) + +signature IFLOW = sig + + val check : Mono.file -> unit + + val debug : bool ref + +end diff --git a/src/iflow.sml b/src/iflow.sml new file mode 100644 index 0000000..5e8d697 --- /dev/null +++ b/src/iflow.sml @@ -0,0 +1,2184 @@ +(* Copyright (c) 2010, 2013, 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 Iflow :> IFLOW = struct + +open Mono +open Sql + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) + +val writers = ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "set_cookie"] + +val writers = SS.addList (SS.empty, writers) + +local + open Print + val string = PD.string +in + +fun p_func f = + string (case f of + DtCon0 s => s + | DtCon1 s => s + | UnCon s => "un" ^ s + | Other s => s) + +fun p_exp e = + case e of + Const p => Prim.p_t p + | Var n => string ("x" ^ Int.toString n) + | Lvar n => string ("X" ^ Int.toString n) + | Func (f, es) => box [p_func f, + string "(", + p_list p_exp es, + string ")"] + | Recd xes => box [string "{", + p_list (fn (x, e) => box [string x, + space, + string "=", + space, + p_exp e]) xes, + string "}"] + | Proj (e, x) => box [p_exp e, + string ("." ^ x)] + +fun p_bop s es = + case es of + [e1, e2] => box [p_exp e1, + space, + string s, + space, + p_exp e2] + | _ => raise Fail "Iflow.p_bop" + +fun p_reln r es = + case r of + Known => + (case es of + [e] => box [string "known(", + p_exp e, + string ")"] + | _ => raise Fail "Iflow.p_reln: Known") + | Sql s => box [string (s ^ "("), + p_list p_exp es, + string ")"] + | PCon0 s => box [string (s ^ "("), + p_list p_exp es, + string ")"] + | PCon1 s => box [string (s ^ "("), + p_list p_exp es, + string ")"] + | Cmp Eq => p_bop "=" es + | Cmp Ne => p_bop "<>" es + | Cmp Lt => p_bop "<" es + | Cmp Le => p_bop "<=" es + | Cmp Gt => p_bop ">" es + | Cmp Ge => p_bop ">=" es + +fun p_prop p = + case p of + True => string "True" + | False => string "False" + | Unknown => string "??" + | Lop (And, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Lop (Or, p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] + | Reln (r, es) => p_reln r es + | Cond (e, p) => box [string "(", + p_exp e, + space, + string "==", + space, + p_prop p, + string ")"] + +end + +fun isKnown e = + case e of + Const _ => true + | Func (_, es) => List.all isKnown es + | Recd xes => List.all (isKnown o #2) xes + | Proj (e, _) => isKnown e + | _ => false + +fun simplify unif = + let + fun simplify e = + case e of + Const _ => e + | Var _ => e + | Lvar n => + (case IM.find (unif, n) of + NONE => e + | SOME e => simplify e) + | Func (f, es) => Func (f, map simplify es) + | Recd xes => Recd (map (fn (x, e) => (x, simplify e)) xes) + | Proj (e, s) => Proj (simplify e, s) + in + simplify + end + +datatype atom = + AReln of reln * exp list + | ACond of exp * prop + +fun p_atom a = + p_prop (case a of + AReln x => Reln x + | ACond x => Cond x) + +(* Congruence closure *) +structure Cc :> sig + type database + + exception Contradiction + + val database : unit -> database + val clear : database -> unit + + val assert : database * atom -> unit + val check : database * atom -> bool + + val p_database : database Print.printer + + val builtFrom : database * {Base : exp list, Derived : exp} -> bool + + val p_repOf : database -> exp Print.printer +end = struct + +local + val count = ref 0 +in +fun nodeId () = + let + val n = !count + in + count := n + 1; + n + end +end + +exception Contradiction +exception Undetermined + +structure CM = BinaryMapFn(struct + type ord_key = Prim.t + val compare = Prim.compare + end) + +datatype node = Node of {Id : int, + Rep : node ref option ref, + Cons : node ref SM.map ref, + Variety : variety, + Known : bool ref, + Ge : Int64.int option ref} + + and variety = + Dt0 of string + | Dt1 of string * node ref + | Prim of Prim.t + | Recrd of node ref SM.map ref * bool + | Nothing + +type representative = node ref + +type database = {Vars : representative IM.map ref, + Consts : representative CM.map ref, + Con0s : representative SM.map ref, + Records : (representative SM.map * representative) list ref, + Funcs : ((string * representative list) * representative) list ref} + +fun database () = {Vars = ref IM.empty, + Consts = ref CM.empty, + Con0s = ref SM.empty, + Records = ref [], + Funcs = ref []} + +fun clear (t : database) = (#Vars t := IM.empty; + #Consts t := CM.empty; + #Con0s t := SM.empty; + #Records t := []; + #Funcs t := []) + +fun unNode n = + case !n of + Node r => r + +open Print +val string = PD.string +val newline = PD.newline + +fun p_rep n = + case !(#Rep (unNode n)) of + SOME n => p_rep n + | NONE => + box [string (Int.toString (#Id (unNode n)) ^ ":"), + space, + case #Variety (unNode n) of + Nothing => string "?" + | Dt0 s => string ("Dt0(" ^ s ^ ")") + | Dt1 (s, n) => box[string ("Dt1(" ^ s ^ ","), + space, + p_rep n, + string ")"] + | Prim p => Prim.p_t p + | Recrd (ref m, b) => box [string "{", + p_list (fn (x, n) => box [string x, + space, + string "=", + space, + p_rep n]) (SM.listItemsi m), + string "}", + if b then + box [space, + string "(complete)"] + else + box []], + if !(#Known (unNode n)) then + string " (known)" + else + box [], + case !(#Ge (unNode n)) of + NONE => box [] + | SOME n => string (" (>= " ^ Int64.toString n ^ ")")] + +fun p_database (db : database) = + box [string "Vars:", + newline, + p_list_sep newline (fn (i, n) => box [string ("x" ^ Int.toString i), + space, + string "=", + space, + p_rep n]) (IM.listItemsi (!(#Vars db)))] + +fun repOf (n : representative) : representative = + case !(#Rep (unNode n)) of + NONE => n + | SOME r => + let + val r = repOf r + in + #Rep (unNode n) := SOME r; + r + end + +fun markKnown r = + let + val r = repOf r + in + (*Print.preface ("markKnown", p_rep r);*) + if !(#Known (unNode r)) then + ()(*TextIO.print "Already known\n"*) + else + (#Known (unNode r) := true; + SM.app markKnown (!(#Cons (unNode r))); + case #Variety (unNode r) of + Dt1 (_, r) => markKnown r + | Recrd (xes, _) => SM.app markKnown (!xes) + | _ => ()) + end + +fun representative (db : database, e) = + let + fun rep e = + case e of + Const p => (case CM.find (!(#Consts db), p) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Prim p, + Known = ref true, + Ge = ref (case p of + Prim.Int n => SOME n + | _ => NONE)}) + in + #Consts db := CM.insert (!(#Consts db), p, r); + r + end) + | Var n => (case IM.find (!(#Vars db), n) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false, + Ge = ref NONE}) + in + #Vars db := IM.insert (!(#Vars db), n, r); + r + end) + | Lvar _ => raise Undetermined + | Func (DtCon0 f, []) => (case SM.find (!(#Con0s db), f) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt0 f, + Known = ref true, + Ge = ref NONE}) + in + #Con0s db := SM.insert (!(#Con0s db), f, r); + r + end) + | Func (DtCon0 _, _) => raise Fail "Iflow.rep: DtCon0" + | Func (DtCon1 f, [e]) => + let + val r = rep e + in + case SM.find (!(#Cons (unNode r)), f) of + SOME r => repOf r + | NONE => + let + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt1 (f, r), + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) + in + #Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r'); + r' + end + end + | Func (DtCon1 _, _) => raise Fail "Iflow.rep: DtCon1" + | Func (UnCon f, [e]) => + let + val r = rep e + in + case #Variety (unNode r) of + Dt1 (f', n) => if f' = f then + repOf n + else + raise Contradiction + | Nothing => + let + val cons = ref SM.empty + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = cons, + Variety = Nothing, + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) + + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = #Cons (unNode r), + Variety = Dt1 (f, r'), + Known = #Known (unNode r), + Ge = ref NONE}) + in + cons := SM.insert (!cons, f, r''); + #Rep (unNode r) := SOME r''; + r' + end + | _ => raise Contradiction + end + | Func (UnCon _, _) => raise Fail "Iflow.rep: UnCon" + | Func (Other f, es) => + let + val rs = map rep es + in + case List.find (fn (x : string * representative list, _) => x = (f, rs)) (!(#Funcs db)) of + NONE => + let + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref (f = "allow"), + Ge = ref NONE}) + in + #Funcs db := ((f, rs), r) :: (!(#Funcs db)); + r + end + | SOME (_, r) => repOf r + end + | Recd xes => + let + val xes = map (fn (x, e) => (x, rep e)) xes + val len = length xes + in + case List.find (fn (xes', _) => + SM.numItems xes' = len + andalso List.all (fn (x, n) => + case SM.find (xes', x) of + NONE => false + | SOME n' => n = repOf n') xes) + (!(#Records db)) of + SOME (_, r) => repOf r + | NONE => + let + val xes = foldl SM.insert' SM.empty xes + + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Recrd (ref xes, true), + Known = ref false, + Ge = ref NONE}) + in + #Records db := (xes, r') :: (!(#Records db)); + r' + end + end + | Proj (e, f) => + let + val r = rep e + in + case #Variety (unNode r) of + Recrd (xes, _) => + (case SM.find (!xes, f) of + SOME r => repOf r + | NONE => let + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) + in + xes := SM.insert (!xes, f, r); + r + end) + | Nothing => + let + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) + + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = #Cons (unNode r), + Variety = Recrd (ref (SM.insert (SM.empty, f, r')), false), + Known = #Known (unNode r), + Ge = ref NONE}) + in + #Rep (unNode r) := SOME r''; + r' + end + | _ => raise Contradiction + end + in + rep e + end + +fun p_repOf db e = p_rep (representative (db, e)) + +fun assert (db, a) = + let + fun markEq (r1, r2) = + let + val r1 = repOf r1 + val r2 = repOf r2 + in + if r1 = r2 then + () + else case (#Variety (unNode r1), #Variety (unNode r2)) of + (Prim p1, Prim p2) => if Prim.equal (p1, p2) then + () + else + raise Contradiction + | (Dt0 f1, Dt0 f2) => if f1 = f2 then + () + else + raise Contradiction + | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then + markEq (r1, r2) + else + raise Contradiction + | (Recrd (xes1, _), Recrd (xes2, _)) => + let + fun unif (xes1, xes2) = + SM.appi (fn (x, r1) => + case SM.find (!xes2, x) of + NONE => xes2 := SM.insert (!xes2, x, r1) + | SOME r2 => markEq (r1, r2)) (!xes1) + in + unif (xes1, xes2); + unif (xes2, xes1) + end + | (Nothing, _) => mergeNodes (r1, r2) + | (_, Nothing) => mergeNodes (r2, r1) + | _ => raise Contradiction + end + + and mergeNodes (r1, r2) = + (#Rep (unNode r1) := SOME r2; + if !(#Known (unNode r1)) then + markKnown r2 + else + (); + if !(#Known (unNode r2)) then + markKnown r1 + else + (); + #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + + case !(#Ge (unNode r1)) of + NONE => () + | SOME n1 => + case !(#Ge (unNode r2)) of + NONE => #Ge (unNode r2) := SOME n1 + | SOME n2 => #Ge (unNode r2) := SOME (Int64.max (n1, n2)); + + compactFuncs ()) + + and compactFuncs () = + let + fun loop funcs = + case funcs of + [] => [] + | (fr as ((f, rs), r)) :: rest => + let + val rest = List.filter (fn ((f' : string, rs'), r') => + if f' = f + andalso ListPair.allEq (fn (r1, r2) => + repOf r1 = repOf r2) + (rs, rs') then + (markEq (r, r'); + false) + else + true) rest + in + fr :: loop rest + end + in + #Funcs db := loop (!(#Funcs db)) + end + in + case a of + ACond _ => () + | AReln x => + case x of + (Known, [e]) => + ((*Print.prefaces "Before" [("e", p_exp e), + ("db", p_database db)];*) + markKnown (representative (db, e))(*; + Print.prefaces "After" [("e", p_exp e), + ("db", p_database db)]*)) + | (PCon0 f, [e]) => + let + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt0 f' => if f = f' then + () + else + raise Contradiction + | Nothing => + (case SM.find (!(#Con0s db), f) of + SOME r' => markEq (r, r') + | NONE => + let + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt0 f, + Known = ref false, + Ge = ref NONE}) + in + #Rep (unNode r) := SOME r'; + #Con0s db := SM.insert (!(#Con0s db), f, r') + end) + | _ => raise Contradiction + end + | (PCon1 f, [e]) => + let + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt1 (f', e') => if f = f' then + () + else + raise Contradiction + | Nothing => + let + val cons = ref SM.empty + + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = cons, + Variety = Nothing, + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) + + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt1 (f, r''), + Known = #Known (unNode r), + Ge = ref NONE}) + in + cons := SM.insert (!cons, f, r'); + #Rep (unNode r) := SOME r' + end + | _ => raise Contradiction + end + | (Cmp Eq, [e1, e2]) => + markEq (representative (db, e1), representative (db, e2)) + | (Cmp Ge, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + case !(#Ge (unNode (repOf r2))) of + NONE => () + | SOME n2 => + case !(#Ge (unNode (repOf r1))) of + NONE => #Ge (unNode (repOf r1)) := SOME n2 + | SOME n1 => #Ge (unNode (repOf r1)) := SOME (Int64.max (n1, n2)) + end + | _ => () + end handle Undetermined => () + +fun check (db, a) = + (case a of + ACond _ => false + | AReln x => + case x of + (Known, [e]) => + let + fun isKnown r = + let + val r = repOf r + in + !(#Known (unNode r)) + orelse case #Variety (unNode r) of + Dt1 (_, r) => isKnown r + | Recrd (xes, true) => List.all isKnown (SM.listItems (!xes)) + | _ => false + end + + val r = representative (db, e) + in + isKnown r + end + | (PCon0 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt0 f' => f' = f + | _ => false) + | (PCon1 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt1 (f', _) => f' = f + | _ => false) + | (Cmp Eq, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + repOf r1 = repOf r2 + end + | (Cmp Ge, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + case (!(#Ge (unNode (repOf r1))), #Variety (unNode (repOf r2))) of + (SOME n1, Prim (Prim.Int n2)) => Int64.>= (n1, n2) + | _ => false + end + | _ => false) + handle Undetermined => false + +fun builtFrom (db, {Base = bs, Derived = d}) = + let + val bs = map (fn b => representative (db, b)) bs + + fun loop d = + let + val d = repOf d + in + !(#Known (unNode d)) + orelse List.exists (fn b => repOf b = d) bs + orelse (case #Variety (unNode d) of + Dt0 _ => true + | Dt1 (_, d) => loop d + | Prim _ => true + | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) + | Nothing => false) + orelse List.exists (fn r => List.exists (fn b => repOf b = repOf r) bs) + (SM.listItems (!(#Cons (unNode d)))) + end + + fun decomp e = + case e of + Func (Other _, es) => List.all decomp es + | _ => loop (representative (db, e)) + in + decomp d + end handle Undetermined => false + +end + +val tabs = ref (SM.empty : (string list * string list list) SM.map) + +fun patCon pc = + case pc of + PConVar n => "C" ^ Int.toString n + | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c + +type check = exp * ErrorMsg.span + +structure St :> sig + val reset : unit -> unit + + type stashed + val stash : unit -> stashed + val reinstate : stashed -> unit + + type stashedPath + val stashPath : unit -> stashedPath + val reinstatePath : stashedPath -> unit + + val nextVar : unit -> int + + val assert : atom list -> unit + + val addPath : check -> unit + + val allowSend : atom list * exp list -> unit + val send : check -> unit + + val allowInsert : atom list -> unit + val insert : ErrorMsg.span -> unit + + val allowDelete : atom list -> unit + val delete : ErrorMsg.span -> unit + + val allowUpdate : atom list -> unit + val update : ErrorMsg.span -> unit + + val havocReln : reln -> unit + val havocCookie : string -> unit + + val check : atom -> bool + + val debug : unit -> unit +end = struct + +val hnames = ref 1 + +type hyps = int * atom list * bool ref + +val db = Cc.database () +val path = ref ([] : ((int * atom list) * check) option ref list) +val hyps = ref (0, [] : atom list, ref false) +val nvar = ref 0 + +fun setHyps (n', hs) = + let + val (n, _, _) = !hyps + in + if n' = n then + () + else + (hyps := (n', hs, ref false); + Cc.clear db; + app (fn a => Cc.assert (db, a)) hs) + end + +fun useKeys () = + let + val changed = ref false + + fun findKeys (hyps, acc) = + case hyps of + [] => rev acc + | (a as AReln (Sql tab, [r1])) :: hyps => + (case SM.find (!tabs, tab) of + NONE => findKeys (hyps, a :: acc) + | SOME (_, []) => findKeys (hyps, a :: acc) + | SOME (_, ks) => + let + fun finder (hyps, acc) = + case hyps of + [] => rev acc + | (a as AReln (Sql tab', [r2])) :: hyps => + if tab' = tab andalso + List.exists (List.all (fn f => + let + val r = + Cc.check (db, + AReln (Cmp Eq, [Proj (r1, f), + Proj (r2, f)])) + in + (*Print.prefaces "Fs" + [("tab", + Print.PD.string tab), + ("r1", + p_exp (Proj (r1, f))), + ("r2", + p_exp (Proj (r2, f))), + ("r", + Print.PD.string + (Bool.toString r))];*) + r + end)) ks then + (changed := true; + Cc.assert (db, AReln (Cmp Eq, [r1, r2])); + finder (hyps, acc)) + else + finder (hyps, a :: acc) + | a :: hyps => finder (hyps, a :: acc) + + val hyps = finder (hyps, []) + in + findKeys (hyps, a :: acc) + end) + | a :: hyps => findKeys (hyps, a :: acc) + + fun loop hs = + let + val hs = findKeys (hs, []) + in + if !changed then + (changed := false; + loop hs) + else + () + end + + val (_, hs, _) = !hyps + in + (*print "useKeys\n";*) + loop hs + end + +fun complete () = + let + val (_, _, bf) = !hyps + in + if !bf then + () + else + (bf := true; + useKeys ()) + end + +type stashed = int * ((int * atom list) * check) option ref list * (int * atom list) +fun stash () = (!nvar, !path, (#1 (!hyps), #2 (!hyps))) +fun reinstate (nv, p, h) = + (nvar := nv; + path := p; + setHyps h) + +type stashedPath = ((int * atom list) * check) option ref list +fun stashPath () = !path +fun reinstatePath p = path := p + +fun nextVar () = + let + val n = !nvar + in + nvar := n + 1; + n + end + +fun assert ats = + let + val n = !hnames + val (_, hs, _) = !hyps + in + hnames := n + 1; + hyps := (n, ats @ hs, ref false); + app (fn a => Cc.assert (db, a)) ats + end + +fun addPath c = path := ref (SOME ((#1 (!hyps), #2 (!hyps)), c)) :: !path + +val sendable = ref ([] : (atom list * exp list) list) + +fun checkGoals goals k = + let + fun checkGoals goals unifs = + case goals of + [] => k unifs + | AReln (Sql tab, [Lvar lv]) :: goals => + let + val saved = stash () + val (_, hyps, _) = !hyps + + fun tryAll unifs hyps = + case hyps of + [] => false + | AReln (Sql tab', [e]) :: hyps => + (tab' = tab andalso + checkGoals goals (IM.insert (unifs, lv, e))) + orelse tryAll unifs hyps + | _ :: hyps => tryAll unifs hyps + in + tryAll unifs hyps + end + | (g as AReln (r, es)) :: goals => + (complete (); + (if Cc.check (db, AReln (r, map (simplify unifs) es)) then + true + else + ((*Print.preface ("Fail", p_atom (AReln (r, map (simplify unifs) es)));*) + false)) + andalso checkGoals goals unifs) + | ACond _ :: _ => false + in + checkGoals goals IM.empty + end + +fun buildable (e, loc) = + let + fun doPols pols acc = + case pols of + [] => + let + val b = Cc.builtFrom (db, {Base = acc, Derived = e}) + in + (*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc), + ("Derived", p_exp e), + ("Hyps", Print.p_list p_atom (#2 (!hyps))), + ("Good", Print.PD.string (Bool.toString b))];*) + b + end + | (goals, es) :: pols => + checkGoals goals (fn unifs => doPols pols (map (simplify unifs) es @ acc)) + orelse doPols pols acc + in + if doPols (!sendable) [] then + () + else + let + val (_, hs, _) = !hyps + in + ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.prefaces "Situation" [("User learns", p_exp e), + ("Hypotheses", Print.p_list p_atom hs), + ("E-graph", Cc.p_database db)] + end + end + +fun checkPaths () = + let + val (n, hs, _) = !hyps + val hs = (n, hs) + in + app (fn r => + case !r of + NONE => () + | SOME (hs, e) => + (r := NONE; + setHyps hs; + buildable e)) (!path); + setHyps hs + end + +fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v)), + ("exps", Print.p_list p_exp (#2 v))];*) + sendable := v :: !sendable) + +fun send (e, loc) = ((*Print.preface ("Send[" ^ Bool.toString uk ^ "]", p_exp e);*) + complete (); + checkPaths (); + if isKnown e then + () + else + buildable (e, loc)) + +fun doable pols (loc : ErrorMsg.span) = + let + val pols = !pols + in + complete (); + if List.exists (fn goals => + if checkGoals goals (fn _ => true) then + ((*Print.prefaces "Match" [("goals", Print.p_list p_atom goals), + ("hyps", Print.p_list p_atom (#2 (!hyps)))];*) + true) + else + ((*Print.prefaces "No match" [("goals", Print.p_list p_atom goals)(*, + ("hyps", Print.p_list p_atom (#2 (!hyps)))*)];*) + false)) pols then + () + else + let + val (_, hs, _) = !hyps + in + ErrorMsg.errorAt loc "The database update policy may be violated here."; + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs)(*, + ("E-graph", Cc.p_database db)*)] + end + end + +val insertable = ref ([] : atom list list) +fun allowInsert v = insertable := v :: !insertable +val insert = doable insertable + +val updatable = ref ([] : atom list list) +fun allowUpdate v = updatable := v :: !updatable +val update = doable updatable + +val deletable = ref ([] : atom list list) +fun allowDelete v = deletable := v :: !deletable +val delete = doable deletable + +fun reset () = (Cc.clear db; + path := []; + hyps := (0, [], ref false); + nvar := 0; + sendable := []; + insertable := []; + updatable := []; + deletable := []) + +fun havocReln r = + let + val n = !hnames + val (_, hs, _) = !hyps + in + hnames := n + 1; + hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs, ref false) + end + +fun havocCookie cname = + let + val cname = "cookie/" ^ cname + val n = !hnames + val (_, hs, _) = !hyps + in + hnames := n + 1; + hyps := (n, List.filter (fn AReln (Cmp Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + end + +fun check a = Cc.check (db, a) + +fun debug () = + let + val (_, hs, _) = !hyps + in + Print.preface ("Hyps", Print.p_list p_atom hs) + end + +end + + +fun removeDups (ls : (string * string) list) = + case ls of + [] => [] + | x :: ls => + let + val ls = removeDups ls + in + if List.exists (fn x' => x' = x) ls then + ls + else + x :: ls + end + +fun deinj env e = + case #1 e of + ERel n => SOME (List.nth (env, n)) + | EField (e, f) => + (case deinj env e of + NONE => NONE + | SOME e => SOME (Proj (e, f))) + | EApp ((EFfi mf, _), e) => + if Settings.isEffectful mf orelse Settings.isBenignEffectful mf then + NONE + else (case deinj env e of + NONE => NONE + | SOME e => SOME (Func (Other (#1 mf ^ "." ^ #2 mf), [e]))) + | _ => NONE + +fun expIn rv env rvOf = + let + fun expIn e = + let + fun default () = inl (rv ()) + in + case e of + SqConst p => inl (Const p) + | SqTrue => inl (Func (DtCon0 "Basis.bool.True", [])) + | SqFalse => inl (Func (DtCon0 "Basis.bool.False", [])) + | Null => inl (Func (DtCon0 "None", [])) + | SqNot e => + inr (case expIn e of + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + | inr _ => Unknown) + | Field (v, f) => inl (Proj (rvOf v, f)) + | Computed _ => default () + | Binop (bo, e1, e2) => + let + val e1 = expIn e1 + val e2 = expIn e2 + in + inr (case (bo, e1, e2) of + (RCmp c, inl e1, inl e2) => Reln (Cmp c, [e1, e2]) + | (RLop l, v1, v2) => + let + fun pin v = + case v of + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + | inr p => p + in + Lop (l, pin v1, pin v2) + end + | _ => Unknown) + end + | SqKnown e => + (case expIn e of + inl e => inr (Reln (Known, [e])) + | _ => inr Unknown) + | Inj e => + inl (case deinj env e of + NONE => rv () + | SOME e => e) + | SqFunc (f, e) => + (case expIn e of + inl e => inl (Func (Other f, [e])) + | _ => default ()) + + | Unmodeled => inl (Func (Other "allow", [rv ()])) + end + in + expIn + end + +fun decomp {Save = save, Restore = restore, Add = add} = + let + fun go p k = + case p of + True => (k () handle Cc.Contradiction => ()) + | False => () + | Unknown => () + | Lop (And, p1, p2) => go p1 (fn () => go p2 k) + | Lop (Or, p1, p2) => + let + val saved = save () + in + go p1 k; + restore saved; + go p2 k + end + | Reln x => (add (AReln x); k ()) + | Cond x => (add (ACond x); k ()) + in + go + end + +datatype queryMode = + SomeCol of {New : (string * exp) option, Old : (string * exp) option, Outs : exp list} -> unit + | AllCols of exp -> unit + +type 'a doQuery = { + Env : exp list, + NextVar : unit -> exp, + Add : atom -> unit, + Save : unit -> 'a, + Restore : 'a -> unit, + Cont : queryMode +} + +fun doQuery (arg : 'a doQuery) (e as (_, loc)) = + let + fun default () = (ErrorMsg.errorAt loc "Information flow checker can't parse SQL query"; + Print.preface ("Query", MonoPrint.p_exp MonoEnv.empty e)) + in + case parse query e of + NONE => default () + | SOME q => + let + fun doQuery q = + case q of + Query1 r => + let + val new = ref NONE + val old = ref NONE + + val rvs = map (fn Table (tab, v) => + let + val nv = #NextVar arg () + in + case v of + "New" => new := SOME (tab, nv) + | "Old" => old := SOME (tab, nv) + | _ => (); + (v, nv) + end + | _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.queryProp: Bad table variable" + | SOME (_, e) => e + + val expIn = expIn (#NextVar arg) (#Env arg) rvOf + + val saved = #Save arg () + fun addFrom () = app (fn Table (t, v) => #Add arg (AReln (Sql t, [rvOf v])) + | _ => raise Fail "Iflow: not ready for joins or nesteds") (#From r) + + fun usedFields e = + case e of + SqConst _ => [] + | SqTrue => [] + | SqFalse => [] + | Null => [] + | SqNot e => usedFields e + | Field (v, f) => [(false, Proj (rvOf v, f))] + | Computed _ => [] + | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 + | SqKnown _ => [] + | Inj e => + (case deinj (#Env arg) e of + NONE => (ErrorMsg.errorAt loc "Expression injected into SQL is too complicated"; + []) + | SOME e => [(true, e)]) + | SqFunc (_, e) => usedFields e + | Unmodeled => [] + + fun normal' () = + case #Cont arg of + SomeCol k => + let + val sis = map (fn si => + case si of + SqField (v, f) => Proj (rvOf v, f) + | SqExp (e, f) => + case expIn e of + inr _ => #NextVar arg () + | inl e => e) (#Select r) + in + k {New = !new, Old = !old, Outs = sis} + end + | AllCols k => + let + val (ts, es) = + foldl (fn (si, (ts, es)) => + case si of + SqField (v, f) => + let + val fs = getOpt (SM.find (ts, v), SM.empty) + in + (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es) + end + | SqExp (e, f) => + let + val e = + case expIn e of + inr _ => #NextVar arg () + | inl e => e + in + (ts, SM.insert (es, f, e)) + end) + (SM.empty, SM.empty) (#Select r) + in + k (Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) + (SM.listItemsi ts) + @ SM.listItemsi es)) + end + + fun doWhere final = + (addFrom (); + case #Where r of + NONE => final () + | SOME e => + let + val p = case expIn e of + inl e => Reln (Cmp Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + | inr p => p + + val saved = #Save arg () + in + decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} + p (fn () => final () handle Cc.Contradiction => ()); + #Restore arg saved + end) + handle Cc.Contradiction => () + + fun normal () = doWhere normal' + in + (case #Select r of + [SqExp (Binop (RCmp bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo of + Gt => + (case #Cont arg of + SomeCol _ => () + | AllCols k => + let + fun answer e = k (Recd [(f, e)]) + + val saved = #Save arg () + val () = (answer (Func (DtCon0 "Basis.bool.False", []))) + handle Cc.Contradiction => () + in + #Restore arg saved; + (*print "True time!\n";*) + doWhere (fn () => answer (Func (DtCon0 "Basis.bool.True", []))); + #Restore arg saved + end) + | _ => normal ()) + | _ => normal ()) + before #Restore arg saved + end + | Union (q1, q2) => + let + val saved = #Save arg () + in + doQuery q1; + #Restore arg saved; + doQuery q2; + #Restore arg saved + end + in + doQuery q + end + end + +fun evalPat env e (pt, _) = + case pt of + PVar _ => e :: env + | PPrim _ => env + | PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env) + | PCon (_, pc, SOME pt) => + let + val env = evalPat env (Func (UnCon (patCon pc), [e])) pt + in + St.assert [AReln (PCon1 (patCon pc), [e])]; + env + end + | PRecord xpts => + foldl (fn ((x, pt, _), env) => evalPat env (Proj (e, x)) pt) env xpts + | PNone _ => (St.assert [AReln (PCon0 "None", [e])]; env) + | PSome (_, pt) => + let + val env = evalPat env (Func (UnCon "Some", [e])) pt + in + St.assert [AReln (PCon1 "Some", [e])]; + env + end + +datatype arg_mode = Fixed | Decreasing | Arbitrary +type rfun = {args : arg_mode list, tables : SS.set, cookies : SS.set, body : Mono.exp} +val rfuns = ref (IM.empty : rfun IM.map) + +fun evalExp env (e as (_, loc)) k = + let + (*val () = St.debug ()*) + (*val () = Print.preface ("evalExp", MonoPrint.p_exp MonoEnv.empty e)*) + + fun default () = k (Var (St.nextVar ())) + + fun doFfi (m, s, es) = + if m = "Basis" andalso SS.member (writers, s) then + let + fun doArgs es = + case es of + [] => + (if s = "set_cookie" then + case es of + [_, (cname, _), _, _, _] => + (case #1 cname of + EPrim (Prim.String (_, cname)) => + St.havocCookie cname + | _ => ()) + | _ => () + else + (); + k (Recd [])) + | (e, _) :: es => + evalExp env e (fn e => (St.send (e, loc); doArgs es)) + in + doArgs es + end + else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then + default () + else + let + fun doArgs (es, acc) = + case es of + [] => k (Func (Other (m ^ "." ^ s), rev acc)) + | (e, _) :: es => + evalExp env e (fn e => doArgs (es, e :: acc)) + in + doArgs (es, []) + end + in + case #1 e of + EPrim p => k (Const p) + | ERel n => k (List.nth (env, n)) + | ENamed _ => default () + | ECon (_, pc, NONE) => k (Func (DtCon0 (patCon pc), [])) + | ECon (_, pc, SOME e) => evalExp env e (fn e => k (Func (DtCon1 (patCon pc), [e]))) + | ENone _ => k (Func (DtCon0 "None", [])) + | ESome (_, e) => evalExp env e (fn e => k (Func (DtCon1 "Some", [e]))) + | EFfi _ => default () + + | EFfiApp ("Basis", "rand", []) => + let + val e = Var (St.nextVar ()) + in + St.assert [AReln (Known, [e])]; + k e + end + | EFfiApp x => doFfi x + | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [(e, (TRecord [], loc))]) + + | EApp (e1 as (EError _, _), _) => evalExp env e1 k + + | EApp (e1, e2) => + let + fun adefault () = (ErrorMsg.errorAt loc "Excessively fancy function call"; + Print.preface ("Call", MonoPrint.p_exp MonoEnv.empty e); + default ()) + + fun doArgs (e, args) = + case #1 e of + EApp (e1, e2) => doArgs (e1, e2 :: args) + | ENamed n => + (case IM.find (!rfuns, n) of + NONE => adefault () + | SOME rf => + if length (#args rf) <> length args then + adefault () + else + let + val () = (SS.app (St.havocReln o Sql) (#tables rf); + SS.app St.havocCookie (#cookies rf)) + val saved = St.stash () + + fun doArgs (args, modes, env') = + case (args, modes) of + ([], []) => (evalExp env' (#body rf) (fn _ => ()); + St.reinstate saved; + default ()) + + | (arg :: args, mode :: modes) => + evalExp env arg (fn arg => + let + val v = case mode of + Arbitrary => Var (St.nextVar ()) + | Fixed => arg + | Decreasing => + let + val v = Var (St.nextVar ()) + in + if St.check (AReln (Known, [arg])) then + St.assert [(AReln (Known, [v]))] + else + (); + v + end + in + doArgs (args, modes, v :: env') + end) + | _ => raise Fail "Iflow.doArgs: Impossible" + in + doArgs (args, #args rf, []) + end) + | _ => adefault () + in + doArgs (e, []) + end + + | EAbs _ => default () + | EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1]))) + | EBinop (_, s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) + | ERecord xets => + let + fun doFields (xes, acc) = + case xes of + [] => k (Recd (rev acc)) + | (x, e, _) :: xes => + evalExp env e (fn e => doFields (xes, (x, e) :: acc)) + in + doFields (xets, []) + end + | EField (e, s) => evalExp env e (fn e => k (Proj (e, s))) + | ECase (e, pes, {result = res, ...}) => + evalExp env e (fn e => + if List.all (fn (_, (EWrite (EPrim _, _), _)) => true + | _ => false) pes then + (St.send (e, loc); + k (Recd [])) + else + (St.addPath (e, loc); + app (fn (p, pe) => + let + val saved = St.stash () + in + let + val env = evalPat env e p + in + evalExp env pe k; + St.reinstate saved + end + handle Cc.Contradiction => St.reinstate saved + end) pes)) + | EStrcat (e1, e2) => + evalExp env e1 (fn e1 => + evalExp env e2 (fn e2 => + k (Func (Other "cat", [e1, e2])))) + | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) + | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization" + | EReturnBlob {blob = SOME b, mimeType = m, ...} => + evalExp env b (fn b => + (St.send (b, loc); + evalExp env m + (fn m => St.send (m, loc)))) + | ERedirect (e, _) => + evalExp env e (fn e => St.send (e, loc)) + | EWrite e => + evalExp env e (fn e => (St.send (e, loc); + k (Recd []))) + | ESeq (e1, e2) => + let + val path = St.stashPath () + in + evalExp env e1 (fn _ => (St.reinstatePath path; evalExp env e2 k)) + end + | ELet (_, _, e1, e2) => + evalExp env e1 (fn e1 => evalExp (e1 :: env) e2 k) + | EClosure (n, es) => + let + fun doArgs (es, acc) = + case es of + [] => k (Func (Other ("Cl" ^ Int.toString n), rev acc)) + | e :: es => + evalExp env e (fn e => doArgs (es, e :: acc)) + in + doArgs (es, []) + end + + | EQuery {query = q, body = b, initial = i, state = state, ...} => + evalExp env i (fn i => + let + val r = Var (St.nextVar ()) + val acc = Var (St.nextVar ()) + + val (ts, cs) = MonoUtil.Exp.fold {typ = fn (_, st) => st, + exp = fn (e, st as (cs, ts)) => + case e of + EDml (e, _) => + (case parse dml e of + NONE => st + | SOME c => + case c of + Insert _ => st + | Delete (tab, _) => + (cs, SS.add (ts, tab)) + | Update (tab, _, _) => + (cs, SS.add (ts, tab))) + | EFfiApp ("Basis", "set_cookie", + [_, ((EPrim (Prim.String (_, cname)), _), _), + _, _, _]) => + (SS.add (cs, cname), ts) + | _ => st} + (SS.empty, SS.empty) b + in + case (#1 state, SS.isEmpty ts, SS.isEmpty cs) of + (TRecord [], true, true) => () + | _ => + let + val saved = St.stash () + in + (k i) + handle Cc.Contradiction => (); + St.reinstate saved + end; + + SS.app (St.havocReln o Sql) ts; + SS.app St.havocCookie cs; + + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + Cont = AllCols (fn x => + (St.assert [AReln (Cmp Eq, [r, x])]; + evalExp (acc :: r :: env) b k))} q + end) + | EDml (e, _) => + (case parse dml e of + NONE => (print ("Warning: Information flow checker can't parse DML command at " + ^ ErrorMsg.spanToString loc ^ "\n"); + default ()) + | SOME d => + case d of + Insert (tab, es) => + let + val new = St.nextVar () + + val expIn = expIn (Var o St.nextVar) env + (fn _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [1]") + + val es = map (fn (x, e) => + case expIn e of + inl e => (x, e) + | inr _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [2]") + es + + val saved = St.stash () + in + St.assert [AReln (Sql (tab ^ "$New"), [Recd es])]; + St.insert loc; + St.reinstate saved; + St.assert [AReln (Sql tab, [Recd es])]; + k (Recd []) + end + | Delete (tab, e) => + let + val old = St.nextVar () + + val expIn = expIn (Var o St.nextVar) env + (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") + + val p = case expIn e of + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + | inr p => p + + val saved = St.stash () + in + St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), + AReln (Sql (tab), [Var old])]; + decomp {Save = St.stash, + Restore = St.reinstate, + Add = fn a => St.assert [a]} p + (fn () => (St.delete loc; + St.reinstate saved; + St.havocReln (Sql tab); + k (Recd [])) + handle Cc.Contradiction => ()) + end + | Update (tab, fs, e) => + let + val new = St.nextVar () + val old = St.nextVar () + + val expIn = expIn (Var o St.nextVar) env + (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") + + val fs = map + (fn (x, e) => + (x, case expIn e of + inl e => e + | inr _ => raise Fail + ("Iflow.evalExp: Selecting " + ^ "boolean expression"))) + fs + + val fs' = case SM.find (!tabs, tab) of + NONE => raise Fail "Iflow.evalExp: Updating unknown table" + | SOME (fs', _) => fs' + + val fs = foldl (fn (f, fs) => + if List.exists (fn (f', _) => f' = f) fs then + fs + else + (f, Proj (Var old, f)) :: fs) fs fs' + + val p = case expIn e of + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + | inr p => p + val saved = St.stash () + in + St.assert [AReln (Sql (tab ^ "$New"), [Recd fs]), + AReln (Sql (tab ^ "$Old"), [Var old]), + AReln (Sql tab, [Var old])]; + decomp {Save = St.stash, + Restore = St.reinstate, + Add = fn a => St.assert [a]} p + (fn () => (St.update loc; + St.reinstate saved; + St.havocReln (Sql tab); + k (Recd [])) + handle Cc.Contradiction => ()) + end) + + | ENextval (EPrim (Prim.String (_, seq)), _) => + let + val nv = St.nextVar () + in + St.assert [AReln (Sql (String.extract (seq, 3, NONE)), [Var nv])]; + k (Var nv) + end + | ENextval _ => default () + | ESetval _ => default () + + | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String (_, cname)), _), _)]), _), _, _) => + let + val e = Var (St.nextVar ()) + val e' = Func (Other ("cookie/" ^ cname), []) + in + St.assert [AReln (Known, [e]), AReln (Cmp Eq, [e, e'])]; + k e + end + + | EUnurlify _ => default () + | EJavaScript _ => default () + | ESignalReturn _ => default () + | ESignalBind _ => default () + | ESignalSource _ => default () + | EServerCall _ => default () + | ERecv _ => default () + | ESleep _ => default () + | ESpawn _ => default () + end + +datatype var_source = Input of int | SubInput of int | Unknown + +structure U = MonoUtil + +fun mliftExpInExp by = + U.Exp.mapB {typ = fn t => t, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + by) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +fun nameSubexps k (e : Mono.exp) = + let + fun numParams (e : Mono.exp) = + case #1 e of + EStrcat (e1, e2) => numParams e1 + numParams e2 + | EPrim (Prim.String _) => 0 + | _ => 1 + + val nps = numParams e + + fun getParams (e : Mono.exp) x = + case #1 e of + EStrcat (e1, e2) => + let + val (ps1, e1') = getParams e1 x + val (ps2, e2') = getParams e2 (x - length ps1) + in + (ps2 @ ps1, (EStrcat (e1', e2'), #2 e)) + end + | EPrim (Prim.String _) => ([], e) + | _ => + let + val (e', k) = + case #1 e of + EFfiApp (m, f, [(e', t)]) => + if Settings.isEffectful (m, f) orelse Settings.isBenignEffectful (m, f) then + (e, fn x => x) + else + (e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e)) + | ECase (e', ps as + [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String (_, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String (_, "FALSE")), _))], q) => + (e', fn e' => (ECase (e', ps, q), #2 e)) + | _ => (e, fn x => x) + in + ([e'], k (ERel x, #2 e)) + end + + val (ps, e') = getParams e (nps - 1) + + val string = (TFfi ("Basis", "string"), #2 e) + + val (e', _) = foldl (fn (p, (e', liftBy)) => + ((ELet ("p" ^ Int.toString liftBy, + string, + mliftExpInExp liftBy 0 p, + e'), #2 e), liftBy - 1)) (k (nps, e'), nps - 1) ps + in + #1 e' + end + +val namer = MonoUtil.File.map {typ = fn t => t, + exp = fn e => + case e of + EDml (e, fm) => + nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e + | EQuery {exps, tables, state, query, body, initial} => + nameSubexps (fn (liftBy, e') => + (EQuery {exps = exps, + tables = tables, + state = state, + query = e', + body = mliftExpInExp liftBy 2 body, + initial = mliftExpInExp liftBy 0 initial}, + #2 query)) query + | _ => e, + decl = fn d => d} + +fun check (file : file) = + let + val () = (St.reset (); + rfuns := IM.empty) + + (*val () = Print.preface ("FilePre", MonoPrint.p_file MonoEnv.empty file)*) + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + val file = MonoShake.shake file + val file = namer file + (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*) + + val exptd = foldl (fn ((d, _), exptd) => + case d of + DExport (_, _, n, _, _, _) => IS.add (exptd, n) + | _ => exptd) IS.empty (#1 file) + + fun decl (d, loc) = + case d of + DTable (tab, fs, pk, _) => + let + val ks = + case #1 pk of + EPrim (Prim.String (_, s)) => + (case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of + [] => [] + | pk => [pk]) + | _ => [] + in + if size tab >= 3 then + tabs := SM.insert (!tabs, String.extract (tab, 3, NONE), + (map #1 fs, + map (map (fn s => str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE))) ks)) + else + raise Fail "Table name does not begin with uw_" + end + | DVal (x, n, _, e, _) => + let + (*val () = print ("\n=== " ^ x ^ " ===\n\n");*) + + val isExptd = IS.member (exptd, n) + + val saved = St.stash () + + fun deAbs (e, env, ps) = + case #1 e of + EAbs (_, _, _, e) => + let + val nv = Var (St.nextVar ()) + in + deAbs (e, nv :: env, + if isExptd then + AReln (Known, [nv]) :: ps + else + ps) + end + | _ => (e, env, ps) + + val (e, env, ps) = deAbs (e, [], []) + in + St.assert ps; + (evalExp env e (fn _ => ()) handle Cc.Contradiction => ()); + St.reinstate saved + end + + | DValRec [(x, n, _, e, _)] => + let + val tables = ref SS.empty + val cookies = ref SS.empty + + fun deAbs (e, env, modes) = + case #1 e of + EAbs (_, _, _, e) => deAbs (e, Input (length env) :: env, ref Fixed :: modes) + | _ => (e, env, rev modes) + + val (e, env, modes) = deAbs (e, [], []) + + fun doExp env (e as (_, loc)) = + case #1 e of + EPrim _ => e + | ERel _ => e + | ENamed _ => e + | ECon (_, _, NONE) => e + | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (doExp env e)), loc) + | ENone _ => e + | ESome (t, e) => (ESome (t, doExp env e), loc) + | EFfi _ => e + | EFfiApp (m, f, es) => + (case (m, f, es) of + ("Basis", "set_cookie", [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) => + cookies := SS.add (!cookies, cname) + | _ => (); + (EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc)) + + | EApp (e1, e2) => + let + fun default () = (EApp (doExp env e1, doExp env e2), loc) + + fun explore (e, args) = + case #1 e of + EApp (e1, e2) => explore (e1, e2 :: args) + | ENamed n' => + if n' = n then + let + fun doArgs (pos, args, modes) = + case (args, modes) of + ((e1, _) :: args, m1 :: modes) => + (case e1 of + ERel n => + (case List.nth (env, n) of + Input pos' => + if pos' = pos then + () + else + m1 := Arbitrary + | SubInput pos' => + if pos' = pos then + if !m1 = Arbitrary then + () + else + m1 := Decreasing + else + m1 := Arbitrary + | Unknown => m1 := Arbitrary) + | _ => m1 := Arbitrary; + doArgs (pos + 1, args, modes)) + | (_ :: _, []) => () + | ([], ms) => app (fn m => m := Arbitrary) ms + in + doArgs (0, args, modes); + (EFfi ("Basis", "?"), loc) + end + else + default () + | _ => default () + in + explore (e, []) + end + | EAbs (x, t1, t2, e) => (EAbs (x, t1, t2, doExp (Unknown :: env) e), loc) + | EUnop (uo, e1) => (EUnop (uo, doExp env e1), loc) + | EBinop (bi, bo, e1, e2) => (EBinop (bi, bo, doExp env e1, doExp env e2), loc) + | ERecord xets => (ERecord (map (fn (x, e, t) => (x, doExp env e, t)) xets), loc) + | EField (e1, f) => (EField (doExp env e1, f), loc) + | ECase (e, pes, ts) => + let + val source = + case #1 e of + ERel n => + (case List.nth (env, n) of + Input n => SOME n + | SubInput n => SOME n + | Unknown => NONE) + | _ => NONE + + fun doV v = + let + fun doPat (p, env) = + case #1 p of + PVar _ => v :: env + | PPrim _ => env + | PCon (_, _, NONE) => env + | PCon (_, _, SOME p) => doPat (p, env) + | PRecord xpts => foldl (fn ((_, p, _), env) => doPat (p, env)) env xpts + | PNone _ => env + | PSome (_, p) => doPat (p, env) + in + (ECase (e, map (fn (p, e) => (p, doExp (doPat (p, env)) e)) pes, ts), loc) + end + in + case source of + NONE => doV Unknown + | SOME inp => doV (SubInput inp) + end + | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc) + | EError (e1, t) => (EError (doExp env e1, t), loc) + | EReturnBlob {blob = NONE, mimeType = m, t} => + (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc) + | EReturnBlob {blob = SOME b, mimeType = m, t} => + (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc) + | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc) + | EWrite e1 => (EWrite (doExp env e1), loc) + | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc) + | EClosure (n, es) => (EClosure (n, map (doExp env) es), loc) + | EQuery {exps, tables, state, query, body, initial} => + (EQuery {exps = exps, tables = tables, state = state, + query = doExp env query, + body = doExp (Unknown :: Unknown :: env) body, + initial = doExp env initial}, loc) + | EDml (e1, mode) => + (case parse dml e1 of + NONE => () + | SOME c => + case c of + Insert _ => () + | Delete (tab, _) => + tables := SS.add (!tables, tab) + | Update (tab, _, _) => + tables := SS.add (!tables, tab); + (EDml (doExp env e1, mode), loc)) + | ENextval e1 => (ENextval (doExp env e1), loc) + | ESetval (e1, e2) => (ESetval (doExp env e1, doExp env e2), loc) + | EUnurlify (e1, t, b) => (EUnurlify (doExp env e1, t, b), loc) + | EJavaScript (m, e) => (EJavaScript (m, doExp env e), loc) + | ESignalReturn _ => e + | ESignalBind _ => e + | ESignalSource _ => e + | EServerCall _ => e + | ERecv _ => e + | ESleep _ => e + | ESpawn _ => e + + val e = doExp env e + in + rfuns := IM.insert (!rfuns, n, {tables = !tables, cookies = !cookies, + args = map (fn r => !r) modes, body = e}) + end + + | DValRec _ => ErrorMsg.errorAt loc "Iflow can't check mutually-recursive functions yet." + + | DPolicy pol => + let + val rvN = ref 0 + fun rv () = + let + val n = !rvN + in + rvN := n + 1; + Lvar n + end + + val atoms = ref ([] : atom list) + fun doQ k = doQuery {Env = [], + NextVar = rv, + Add = fn a => atoms := a :: !atoms, + Save = fn () => !atoms, + Restore = fn ls => atoms := ls, + Cont = SomeCol (fn r => k (rev (!atoms), r))} + + fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) => + tab' <> tab + orelse List.all (fn Lvar lv' => lv' <> lv + | _ => false) nams + | _ => true) + in + case pol of + PolClient e => + doQ (fn (ats, {Outs = es, ...}) => St.allowSend (ats, es)) e + | PolInsert e => + doQ (fn (ats, {New = SOME (tab, new), ...}) => + St.allowInsert (AReln (Sql (tab ^ "$New"), [new]) :: untab (tab, [new]) ats) + | _ => raise Fail "Iflow: No New in mayInsert policy") e + | PolDelete e => + doQ (fn (ats, {Old = SOME (tab, old), ...}) => + St.allowDelete (AReln (Sql (tab ^ "$Old"), [old]) :: untab (tab, [old]) ats) + | _ => raise Fail "Iflow: No Old in mayDelete policy") e + | PolUpdate e => + doQ (fn (ats, {New = SOME (tab, new), Old = SOME (_, old), ...}) => + St.allowUpdate (AReln (Sql (tab ^ "$Old"), [old]) + :: AReln (Sql (tab ^ "$New"), [new]) + :: untab (tab, [new, old]) ats) + | _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e + | PolSequence e => + (case #1 e of + EPrim (Prim.String (_, seq)) => + let + val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) + val outs = [Lvar 0] + in + St.allowSend ([p], outs) + end + | _ => ()) + end + + | _ => () + in + app decl (#1 file) + end + +val check = fn file => + let + val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + MonoReduce.fullMode := true; + check file; + Settings.setMonoInline oldInline) + handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; + raise ex) + end + +end diff --git a/src/jscomp.sig b/src/jscomp.sig new file mode 100644 index 0000000..5b8723b --- /dev/null +++ b/src/jscomp.sig @@ -0,0 +1,36 @@ +(* Copyright (c) 2008, 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 JSCOMP = sig + + val process : Mono.file -> Mono.file + + val explainEmbed : bool ref + (* Output verbose error messages about inability to embed server-side + * values in client-side code? *) + +end diff --git a/src/jscomp.sml b/src/jscomp.sml new file mode 100644 index 0000000..dedcb55 --- /dev/null +++ b/src/jscomp.sml @@ -0,0 +1,1369 @@ +(* Copyright (c) 2008-2013, 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 JsComp :> JSCOMP = struct + +open Mono + +structure EM = ErrorMsg +structure E = MonoEnv +structure U = MonoUtil + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = U.Typ.compare + end) + +val explainEmbed = ref false + +type state = { + decls : (string * int * (string * int * typ option) list) list, + script : string list, + included : IS.set, + injectors : int IM.map, + listInjectors : int TM.map, + decoders : int IM.map, + maxName : int +} + +fun strcat loc es = + case es of + [] => (EPrim (Prim.String (Prim.Normal, "")), loc) + | [x] => x + | x :: es' => (EStrcat (x, strcat loc es'), loc) + +exception CantEmbed of typ + +fun inString {needle, haystack} = String.isSubstring needle haystack + +fun process (file : file) = + let + val (someTs, nameds) = + foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) + | ((DValRec vis, _), (someTs, nameds)) => + (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) + nameds vis) + | ((DDatatype dts, _), state as (someTs, nameds)) => + (foldl (fn ((_, _, cs), someTs) => + if ElabUtil.classifyDatatype cs = Option then + foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) + | (_, someTs) => someTs) someTs cs + else + someTs) someTs dts, + nameds) + | (_, state) => state) + (IM.empty, IM.empty) (#1 file) + + fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) + + fun isNullable (t, _) = + case t of + TOption _ => true + | TList _ => true + | TDatatype (_, ref (Option, _)) => true + | TRecord [] => true + | _ => false + + fun quoteExp loc (t : typ) (e, st) = + case #1 t of + TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st) + + | TRecord [] => (str loc "null", st) + | TRecord [(x, t)] => + let + val (e, st) = quoteExp loc t ((EField (e, x), loc), st) + in + (strcat loc [str loc ("{_" ^ x ^ ":"), + e, + str loc "}"], st) + end + | TRecord ((x, t) :: xts) => + let + val (e', st) = quoteExp loc t ((EField (e, x), loc), st) + val (es, st) = ListUtil.foldlMap + (fn ((x, t), st) => + let + val (e, st) = quoteExp loc t ((EField (e, x), loc), st) + in + (strcat loc [str loc (",_" ^ x ^ ":"), e], st) + end) + st xts + in + (strcat loc (str loc ("{_" ^ x ^ ":") + :: e' + :: es + @ [str loc "}"]), st) + end + + | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st) + | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st) + | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st) + | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st) + | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st) + | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st) + + | TFfi ("Basis", "bool") => ((ECase (e, + [((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, NONE), loc), + str loc "true"), + ((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, NONE), loc), + str loc "false")], + {disc = (TFfi ("Basis", "bool"), loc), + result = (TFfi ("Basis", "string"), loc)}), loc), + st) + + | TOption t => + let + val (e', st) = quoteExp loc t ((ERel 0, loc), st) + in + (case #1 e' of + EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH" + | _ => + (ECase (e, + [((PNone t, loc), + str loc "null"), + ((PSome (t, (PVar ("x", t), loc)), loc), + if isNullable t then + strcat loc [str loc "{v:", e', str loc "}"] + else + e')], + {disc = (TOption t, loc), + result = (TFfi ("Basis", "string"), loc)}), loc), + st) + end + + | TList t' => + (case TM.find (#listInjectors st, t') of + SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | NONE => + let + val rt = (TRecord [("1", t'), ("2", t)], loc) + + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = TM.insert (#listInjectors st, t', n'), + decoders = #decoders st, + maxName = n' + 1} + + val s = (TFfi ("Basis", "string"), loc) + val (e', st) = quoteExp loc t' ((EField ((ERel 0, loc), "1"), loc), st) + + val body = (ECase ((ERel 0, loc), + [((PNone rt, loc), + str loc "null"), + ((PSome (rt, (PVar ("x", rt), loc)), loc), + strcat loc [str loc "{_1:", + e', + str loc ",_2:", + (EApp ((ENamed n', loc), + (EField ((ERel 0, loc), "2"), loc)), loc), + str loc "}"])], + {disc = t, result = s}), loc) + val body = (EAbs ("x", t, s, body), loc) + + val st = {decls = ("jsify", n', (TFun (t, s), loc), + body, "jsify") :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders= #decoders st, + maxName = #maxName st} + + + in + ((EApp ((ENamed n', loc), e), loc), st) + end) + + | TDatatype (n, ref (dk, cs)) => + (case IM.find (#injectors st, n) of + SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | NONE => + let + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = IM.insert (#injectors st, n, n'), + listInjectors = #listInjectors st, + decoders = #decoders st, + maxName = n' + 1} + + val (pes, st) = ListUtil.foldlMap + (fn ((_, cn, NONE), st) => + (((PCon (dk, PConVar cn, NONE), loc), + case dk of + Option => str loc "null" + | _ => str loc (Int.toString cn)), + st) + | ((_, cn, SOME t), st) => + let + val (e, st) = quoteExp loc t ((ERel 0, loc), st) + in + (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), + case dk of + Option => + if isNullable t then + strcat loc [str loc "{v:", + e, + str loc "}"] + else + e + | _ => strcat loc [str loc ("{n:" ^ Int.toString cn + ^ ",v:"), + e, + str loc "}"]), + st) + end) + st cs + + val s = (TFfi ("Basis", "string"), loc) + val body = (ECase ((ERel 0, loc), pes, + {disc = t, result = s}), loc) + val body = (EAbs ("x", t, s, body), loc) + + val st = {decls = ("jsify", n', (TFun (t, s), loc), + body, "jsify") :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders= #decoders st, + maxName = #maxName st} + in + ((EApp ((ENamed n', loc), e), loc), st) + end) + + | _ => (if !explainEmbed then + Print.prefaces "Can't embed" [("loc", Print.PD.string (ErrorMsg.spanToString loc)), + ("e", MonoPrint.p_exp MonoEnv.empty e), + ("t", MonoPrint.p_typ MonoEnv.empty t)] + else + (); + raise CantEmbed t) + + fun unurlifyExp loc (t : typ, st) = + case #1 t of + TRecord [] => ("(i++,null)", st) + | TFfi ("Basis", "unit") => ("(i++,null)", st) + | TRecord [(x, t)] => + let + val (e, st) = unurlifyExp loc (t, st) + in + ("{_" ^ x ^ ":" ^ e ^ "}", + st) + end + | TRecord ((x, t) :: xts) => + let + val (e', st) = unurlifyExp loc (t, st) + val (es, st) = ListUtil.foldlMap + (fn ((x, t), st) => + let + val (e, st) = unurlifyExp loc (t, st) + in + (",_" ^ x ^ ":" ^ e, st) + end) + st xts + in + (String.concat ("{_" + :: x + :: ":" + :: e' + :: es + @ ["}"]), st) + end + + | TFfi ("Basis", "string") => ("uu(t[i++])", st) + | TFfi ("Basis", "char") => ("uu(t[i++])", st) + | TFfi ("Basis", "int") => ("parseInt(t[i++])", st) + | TFfi ("Basis", "time") => ("parseInt(t[i++])", st) + | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st) + | TFfi ("Basis", "channel") => ("(t[i++].length > 0 ? parseInt(t[i-1]) : null)", st) + + | TFfi ("Basis", "bool") => ("t[i++] == \"1\"", st) + + | TSource => ("parseSource(t[i++], t[i++])", st) + + | TOption t => + let + val (e, st) = unurlifyExp loc (t, st) + val e = if isNullable t then + "{v:" ^ e ^ "}" + else + e + in + ("(t[i++]==\"Some\"?" ^ e ^ ":null)", st) + end + + | TList t => + let + val (e, st) = unurlifyExp loc (t, st) + in + ("uul(function(){return t[i++];},function(){return " ^ e ^ "})", st) + end + + | TDatatype (n, ref (dk, cs)) => + (case IM.find (#decoders st, n) of + SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) + | NONE => + let + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders = IM.insert (#decoders st, n, n'), + maxName = n' + 1} + + val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) => + ("x==\"" ^ x ^ "\"?" + ^ (case dk of + Option => "null" + | _ => Int.toString cn) + ^ ":" ^ e, + st) + | ((x, cn, SOME t), (e, st)) => + let + val (e', st) = unurlifyExp loc (t, st) + in + ("x==\"" ^ x ^ "\"?" + ^ (case dk of + Option => + if isNullable t then + "{v:" ^ e' ^ "}" + else + e' + | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}") + ^ ":" ^ e, + st) + end) + ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")", st) cs + + val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r=" + ^ e ^ ";return {_1:i,_2:r}}\n\n" + + val st = {decls = #decls st, + script = body :: #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders = #decoders st, + maxName = #maxName st} + in + ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) + end) + + | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript"; + Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)]; + ("ERROR", st)) + + fun padWith (ch, s, len) = + if size s < len then + padWith (ch, String.str ch ^ s, len - 1) + else + s + + val foundJavaScript = ref false + + fun jsExp mode outer = + let + val len = length outer + + fun jsE inner (e as (_, loc), st) = + let + (*val () = Print.prefaces "jsExp" [("e", MonoPrint.p_exp MonoEnv.empty e), + ("loc", Print.PD.string (ErrorMsg.spanToString loc))]*) + + val str = str loc + + fun patCon pc = + case pc of + PConVar n => str (Int.toString n) + | PConFfi {mod = "Basis", con = "True", ...} => str "true" + | PConFfi {mod = "Basis", con = "False", ...} => str "false" + | PConFfi {con, ...} => str ("\"" ^ con ^ "\"") + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); + Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e); + (str "ERROR", st)) + + val strcat = strcat loc + + fun jsPrim p = + let + fun jsChar ch = + case ch of + #"'" => + if mode = Attribute then + "\\047" + else + "'" + | #"\"" => "\\\"" + | #"<" => "\\074" + | #"\\" => "\\\\" + | #"\n" => "\\n" + | #"\r" => "\\r" + | #"\t" => "\\t" + | ch => + if Char.isPrint ch orelse ord ch >= 128 then + String.str ch + else + "\\" ^ padWith (#"0", + Int.fmt StringCvt.OCT (ord ch), + 3) + in + case p of + Prim.String (_, s) => + str ("\"" ^ String.translate jsChar s ^ "\"") + | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"") + | _ => str (Prim.toString p) + end + + fun jsPat (p, _) = + case p of + PVar _ => str "{/*hoho*/c:\"v\"}" + | PPrim p => strcat [str "{c:\"c\",v:", + jsPrim p, + str "}"] + | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => + str "{c:\"c\",v:true}" + | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => + str "{c:\"c\",v:false}" + | PCon (Option, _, NONE) => + str "{c:\"c\",v:null}" + | PCon (Option, PConVar n, SOME p) => + (case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs" + | SOME t => + strcat [str ("{c:\"s\",n:" + ^ (if isNullable t then + "true" + else + "false") + ^ ",p:"), + jsPat p, + str "}"]) + | PCon (_, pc, NONE) => strcat [str "{c:\"c\",v:", + patCon pc, + str "}"] + | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:", + patCon pc, + str ",p:", + jsPat p, + str "}"] + | PRecord xps => strcat [str "{c:\"r\",l:", + foldr (fn ((x, p, _), e) => + strcat [str ("cons({n:\"" ^ x ^ "\",p:"), + jsPat p, + str "},", + e, + str ")"]) + (str "null") xps, + str "}"] + | PNone _ => str "{c:\"c\",v:null}" + | PSome (t, p) => strcat [str ("{c:\"s\",n:" + ^ (if isNullable t then + "true" + else + "false") + ^ ",p:"), + jsPat p, + str "}"] + + val jsifyString = String.translate (fn #"\"" => "\\\"" + | #"\\" => "\\\\" + | ch => String.str ch) + + fun jsifyStringMulti (n, s) = + case n of + 0 => s + | _ => jsifyStringMulti (n - 1, jsifyString s) + + fun deStrcat level (all as (e, loc)) = + case e of + EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s) + | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 + | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" + | _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code"; + Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; + "") + + val quoteExp = quoteExp loc + in + (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), + ("inner", Print.PD.string (Int.toString inner))];*) + + case #1 e of + EPrim p => (strcat [str "{c:\"c\",v:", + jsPrim p, + str "}"], + st) + | ERel n => + if n < inner then + (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st) + else + let + val n = n - inner + (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty + (List.nth (outer, n)))]*) + val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st) + in + (strcat [str "{c:\"c\",v:", + e, + str "}"], st) + end + + | ENamed n => + let + val st = + if IS.member (#included st, n) then + st + else + case IM.find (nameds, n) of + NONE => raise Fail "Jscomp: Unbound ENamed" + | SOME e => + let + val st = {decls = #decls st, + script = #script st, + included = IS.add (#included st, n), + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders = #decoders st, + maxName = #maxName st} + + val old = e + val (e, st) = jsExp mode [] (e, st) + val e = deStrcat 0 e + val e = String.translate (fn #"'" => "\\'" + | #"\\" => "\\\\" + | ch => String.str ch) e + + val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'" + ^ e ^ "'};\n" + in + (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old), + ("new", MonoPrint.p_exp MonoEnv.empty new)];*) + {decls = #decls st, + script = sc :: #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders= #decoders st, + maxName = #maxName st} + end + in + (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st) + end + + | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st) + | ECon (Option, PConVar n, SOME e) => + let + val (e, st) = jsE inner (e, st) + in + case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs [2]" + | SOME t => + (if isNullable t then + strcat [str "{c:\"s\",v:", + e, + str "}"] + else + e, st) + end + + | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:", + patCon pc, + str "}"], + st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{c:\"1\",n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + + | ENone _ => (str "{c:\"c\",v:null}", st) + | ESome (t, e) => + let + val (e, st) = jsE inner (e, st) + in + (if isNullable t then + strcat [str "{c:\"s\",v:", e, str "}"] + else + e, st) + end + + | EFfi k => + let + val name = case Settings.jsFunc k of + NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k + ^ " in JavaScript"); + "ERROR") + | SOME s => s + in + (str ("{c:\"c\",v:" ^ name ^ "}"), st) + end + | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"", + e, + str "\"}"], st) + | EFfiApp (m, x, args) => + let + val name = case Settings.jsFunc (m, x) of + NONE => (EM.errorAt loc ("Unsupported FFI function " + ^ m ^ "." ^ x ^ " in JavaScript"); + "ERROR") + | SOME s => s + + val (e, st) = foldr (fn ((e, _), (acc, st)) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "cons(", + e, + str ",", + acc, + str ")"], + st) + end) + (str "null", st) args + in + (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"), + e, + str "}"], + st) + end + + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "{c:\"a\",f:", + e1, + str ",x:", + e2, + str "}"], st) + end + | EAbs (_, _, _, e) => + let + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat [str "{c:\"l\",b:", + e, + str "}"], st) + end + + | EUnop (s, e) => + let + val name = case s of + "!" => "not" + | "-" => "neg" + | _ => raise Fail ("Jscomp: Unknown unary operator " ^ s) + + val (e, st) = jsE inner (e, st) + in + (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("), + e, + str ",null)}"], + st) + end + | EBinop (bi, s, e1, e2) => + let + val name = case s of + "==" => "eq" + | "!strcmp" => "eq" + | "+" => "plus" + | "-" => "minus" + | "*" => "times" + | "/" => (case bi of Int => "divInt" | NotInt => "div") + | "%" => (case bi of Int => "modInt" | NotInt => "mod") + | "fdiv" => "div" + | "fmod" => "mod" + | "<" => "lt" + | "<=" => "le" + | "strcmp" => "strcmp" + | "powl" => "pow" + | "powf" => "pow" + | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s) + + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("), + e1, + str ",cons(", + e2, + str ",null))}"], + st) + end + + | ERecord [] => (str "{c:\"c\",v:null}", st) + | ERecord xes => + let + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("cons({n:\"" ^ x ^ "\",v:"), + e, + str "},", + es, + str ")"], + st) + end) + (str "null", st) xes + in + (strcat [str "{c:\"r\",l:", + es, + str "}"], + st) + end + | EField (e', x) => + let + fun default () = + let + val (e', st) = jsE inner (e', st) + in + (strcat [str "{c:\".\",r:", + e', + str (",f:\"" ^ x ^ "\"}")], st) + end + + fun seek (e, xs) = + case #1 e of + ERel n => + if n < inner then + default () + else + let + val n = n - inner + val t = List.nth (outer, n) + val t = foldl (fn (x, (TRecord xts, _)) => + (case List.find (fn (x', _) => x' = x) xts of + NONE => raise Fail "Jscomp: Bad seek [1]" + | SOME (_, t) => t) + | _ => raise Fail "Jscomp: Bad seek [2]") + t xs + + val e = (ERel n, loc) + val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs + val (e, st) = quoteExp t (e, st) + in + (strcat [str "{c:\"c\",v:", + e, + str "}"], + st) + end + | EField (e', x) => seek (e', x :: xs) + | _ => default () + in + seek (e', [x]) + end + + | ECase (e', pes, _) => + let + val (e', st) = jsE inner (e', st) + + val (ps, st) = + foldr (fn ((p, e), (ps, st)) => + let + val (e, st) = jsE (inner + E.patBindsN p) (e, st) + in + (strcat [str "cons({p:", + jsPat p, + str ",b:", + e, + str "},", + ps, + str ")"], + st) + end) + (str "null", st) pes + in + (strcat [str "{c:\"m\",e:", + e', + str ",p:", + ps, + str "}"], st) + end + + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st) + end + + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"], + st) + end + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str "{c:\"=\",e1:", + e1, + str ",e2:", + e2, + str "}"], st) + end + + | EJavaScript (Source _, e) => + (foundJavaScript := true; + jsE inner (e, st)) + | EJavaScript (_, e) => + let + val (e, st) = jsE inner (e, st) + in + foundJavaScript := true; + (strcat [str "{c:\"e\",e:", + e, + str "}"], + st) + end + + | EWrite _ => unsupported "EWrite" + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | ESetval _ => unsupported "Nextval" + | EReturnBlob _ => unsupported "EReturnBlob" + + | ERedirect (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:redirect,a:cons(", + e, + str ",null)}"], + st) + end + + | EUnurlify (_, _, true) => unsupported "EUnurlify" + + | EUnurlify (e, t, false) => + let + val (e, st) = jsE inner (e, st) + val (e', st) = unurlifyExp loc (t, st) + in + (strcat [str ("{c:\"f\",f:unurlify,a:cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " + ^ e' ^ "}},cons("), + e, + str ",null))}"], + st) + end + + | ESignalReturn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:sr,a:cons(", + e, + str ",null)}"], + st) + end + | ESignalBind (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "{c:\"f\",f:sb,a:cons(", + e1, + str ",cons(", + e2, + str ",null))}"], + st) + end + | ESignalSource e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:ss,a:cons(", + e, + str ",null)}"], + st) + end + + | EServerCall (e, t, eff, fm) => + let + val (e, st) = jsE inner (e, st) + val (unurl, st) = unurlifyExp loc (t, st) + val lastArg = case fm of + None => "null" + | Error => + let + val isN = if isNullable t then + "true" + else + "false" + in + "cons({c:\"c\",v:" ^ isN ^ "},null)" + end + in + (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" + ^ Settings.getUrlPrefix () + ^ "\"},cons("), + e, + str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " + ^ unurl ^ "}},cons({c:\"K\"},cons({c:\"c\",v:" + ^ (case eff of + ReadCookieWrite => "true" + | _ => "false") + ^ "}," ^ lastArg ^ ")))))}")], + st) + end + + | ERecv (e, t) => + let + val (e, st) = jsE inner (e, st) + val (unurl, st) = unurlifyExp loc (t, st) + in + (strcat [str ("{c:\"f\",f:rv,a:cons("), + e, + str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " + ^ unurl ^ "}},cons({c:\"K\"},null)))}")], + st) + end + + | ESleep e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:sl,a:cons(", + e, + str ",cons({c:\"K\"},null))}"], + st) + end + + | ESpawn e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{c:\"f\",f:sp,a:cons(", + e, + str ",null)}"], + st) + end + end + in + jsE 0 + end + + fun patBinds ((p, _), env) = + case p of + PVar (_, t) => t :: env + | PPrim _ => env + | PCon (_, _, NONE) => env + | PCon (_, _, SOME p) => patBinds (p, env) + | PRecord xpts => foldl (fn ((_, p, _), env) => patBinds (p, env)) env xpts + | PNone _ => env + | PSome (_, p) => patBinds (p, env) + + fun exp outer (e as (_, loc), st) = + ((*Print.preface ("exp", MonoPrint.p_exp MonoEnv.empty e);*) + case #1 e of + EPrim p => + (case p of + Prim.String (_, s) => if inString {needle = "<script", haystack = s} then + foundJavaScript := true + else + () + | _ => (); + (e, st)) + | ERel _ => (e, st) + | ENamed _ => (e, st) + | ECon (_, _, NONE) => (e, st) + | ECon (dk, pc, SOME e) => + let + val (e, st) = exp outer (e, st) + in + ((ECon (dk, pc, SOME e), loc), st) + end + | ENone _ => (e, st) + | ESome (t, e) => + let + val (e, st) = exp outer (e, st) + in + ((ESome (t, e), loc), st) + end + | EFfi _ => (e, st) + | EFfiApp (m, x, es) => + let + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = exp outer (e, st) + in + ((e, t), st) + end) st es + in + ((EFfiApp (m, x, es), loc), st) + end + | EApp (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EApp (e1, e2), loc), st) + end + | EAbs (x, dom, ran, e) => + let + val (e, st) = exp (dom :: outer) (e, st) + in + ((EAbs (x, dom, ran, e), loc), st) + end + + | EUnop (s, e) => + let + val (e, st) = exp outer (e, st) + in + ((EUnop (s, e), loc), st) + end + | EBinop (bi, s, e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EBinop (bi, s, e1, e2), loc), st) + end + + | ERecord xets => + let + val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) => + let + val (e, st) = exp outer (e, st) + in + ((x, e, t), st) + end) st xets + in + ((ERecord xets, loc), st) + end + | EField (e, s) => + let + val (e, st) = exp outer (e, st) + in + ((EField (e, s), loc), st) + end + + | ECase (e, pes, ts) => + let + val (e, st) = exp outer (e, st) + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val (e, st) = exp (patBinds (p, outer)) (e, st) + in + ((p, e), st) + end) st pes + in + ((ECase (e, pes, ts), loc), st) + end + + | EStrcat (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((EStrcat (e1, e2), loc), st) + end + + | EError (e, t) => + let + val (e, st) = exp outer (e, st) + in + ((EError (e, t), loc), st) + end + | EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, st) = exp outer (mimeType, st) + in + ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st) + end + | EReturnBlob {blob = SOME blob, mimeType, t} => + let + val (blob, st) = exp outer (blob, st) + val (mimeType, st) = exp outer (mimeType, st) + in + ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st) + end + | ERedirect (e, t) => + let + val (e, st) = exp outer (e, st) + in + ((ERedirect (e, t), loc), st) + end + + | EWrite e => + let + val (e, st) = exp outer (e, st) + in + ((EWrite e, loc), st) + end + | ESeq (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESeq (e1, e2), loc), st) + end + | ELet (x, t, e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp (t :: outer) (e2, st) + in + ((ELet (x, t, e1, e2), loc), st) + end + + | EClosure (n, es) => + let + val (es, st) = ListUtil.foldlMap (exp outer) st es + in + ((EClosure (n, es), loc), st) + end + + | EQuery {exps, tables, state, query, body, initial} => + let + val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables + val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row + val row = (TRecord row, loc) + + val (query, st) = exp outer (query, st) + val (body, st) = exp (state :: row :: outer) (body, st) + val (initial, st) = exp outer (initial, st) + in + ((EQuery {exps = exps, tables = tables, state = state, + query = query, body = body, initial = initial}, loc), st) + end + | EDml (e, mode) => + let + val (e, st) = exp outer (e, st) + in + ((EDml (e, mode), loc), st) + end + | ENextval e => + let + val (e, st) = exp outer (e, st) + in + ((ENextval e, loc), st) + end + | ESetval (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESetval (e1, e2), loc), st) + end + + | EUnurlify (e, t, b) => + let + val (e, st) = exp outer (e, st) + in + ((EUnurlify (e, t, b), loc), st) + end + + | EJavaScript (m as Source t, e') => + (foundJavaScript := true; + let + val (x', st) = jsExp m (t :: outer) ((ERel 0, loc), st) + in + ((ELet ("x", t, e', x'), loc), st) + end + handle CantEmbed _ => + (jsExp m outer (e', st) + handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript"; + Print.preface ("Type", + MonoPrint.p_typ MonoEnv.empty t);*) + (e, st)))) + + | EJavaScript (m, e') => + (foundJavaScript := true; + jsExp m outer (e', st) + handle CantEmbed t => ((*ErrorMsg.errorAt loc "Unable to embed type in JavaScript"; + Print.preface ("Type", + MonoPrint.p_typ MonoEnv.empty t);*) + (e, st))) + + | ESignalReturn e => + let + val (e, st) = exp outer (e, st) + in + ((ESignalReturn e, loc), st) + end + | ESignalBind (e1, e2) => + let + val (e1, st) = exp outer (e1, st) + val (e2, st) = exp outer (e2, st) + in + ((ESignalBind (e1, e2), loc), st) + end + | ESignalSource e => + let + val (e, st) = exp outer (e, st) + in + ((ESignalSource e, loc), st) + end + + | EServerCall (e1, t, ef, fm) => + let + val (e1, st) = exp outer (e1, st) + in + ((EServerCall (e1, t, ef, fm), loc), st) + end + | ERecv (e1, t) => + let + val (e1, st) = exp outer (e1, st) + in + ((ERecv (e1, t), loc), st) + end + | ESleep e1 => + let + val (e1, st) = exp outer (e1, st) + in + ((ESleep e1, loc), st) + end + | ESpawn e1 => + let + val (e1, st) = exp outer (e1, st) + in + ((ESpawn e1, loc), st) + end) + + fun decl (d as (_, loc), st) = + case #1 d of + DVal (x, n, t, e, s) => + let + val (e, st) = exp [] (e, st) + in + ((DVal (x, n, t, e, s), loc), st) + end + | DValRec vis => + let + val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => + let + val (e, st) = exp [] (e, st) + in + ((x, n, t, e, s), st) + end) st vis + in + ((DValRec vis, loc), st) + end + | _ => (d, st) + + fun doDecl (d, st) = + let + (*val () = Print.preface ("doDecl", MonoPrint.p_decl MonoEnv.empty d)*) + val (d, st) = decl (d, st) + + val ds = + case #decls st of + [] => [d] + | vis => [(DValRec vis, #2 d), d] + in + (ds, + {decls = [], + script = #script st, + included = #included st, + injectors = #injectors st, + listInjectors = #listInjectors st, + decoders = #decoders st, + maxName = #maxName st}) + end + + val (ds, st) = ListUtil.foldlMapConcat doDecl + {decls = [], + script = [], + included = IS.empty, + injectors = IM.empty, + listInjectors = TM.empty, + decoders = IM.empty, + maxName = U.File.maxName file + 1} + (#1 file) + + val inf = FileIO.txtOpenIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) + fun lines acc = + case TextIO.inputLine inf of + NONE => String.concat (rev acc) + | SOME line => lines (line :: acc) + val lines = lines [] + + val urlRules = foldr (fn (r, s) => + "cons({allow:" + ^ (if #action r = Settings.Allow then "true" else "false") + ^ ",prefix:" + ^ (if #kind r = Settings.Prefix then "true" else "false") + ^ ",pattern:\"" + ^ #pattern r + ^ "\"}," + ^ s + ^ ")") "null" (Settings.getUrlRules ()) + + val urlRules = "urlRules = " ^ urlRules ^ ";\n\n" + + val script = + if !foundJavaScript then + String.concatWith "" ((lines ^ urlRules ^ String.concat (rev (#script st)) + ^ "\ntime_format = \"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\";\n") + :: map (fn r => "\n// " ^ #Filename r ^ "\n\n" ^ #Content r ^ "\n") (Settings.listJsFiles ())) + else + "" + in + TextIO.closeIn inf; + ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) + end + +end diff --git a/src/list_key_fn.sml b/src/list_key_fn.sml new file mode 100644 index 0000000..ec2bd26 --- /dev/null +++ b/src/list_key_fn.sml @@ -0,0 +1,14 @@ +functor ListKeyFn(K : ORD_KEY) + : ORD_KEY where type ord_key = K.ord_key list = struct + +type ord_key = K.ord_key list + +val rec compare = + fn ([], []) => EQUAL + | ([], _) => LESS + | (_, []) => GREATER + | (x::xs, y::ys) => case K.compare (x, y) of + EQUAL => compare (xs, ys) + | ord => ord + +end diff --git a/src/list_util.sig b/src/list_util.sig new file mode 100644 index 0000000..6e1cd5a --- /dev/null +++ b/src/list_util.sig @@ -0,0 +1,59 @@ +(* Copyright (c) 2008, 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 LIST_UTIL = sig + + val mapConcat : ('a -> 'b list) -> 'a list -> 'b list + + val mapfold : ('data, 'state, 'abort) Search.mapfolder + -> ('data list, 'state, 'abort) Search.mapfolder + val mapfoldB : ('context * 'data -> 'context * ('state -> ('data * 'state, 'abort) Search.result)) + -> ('context, 'data list, 'state, 'abort) Search.mapfolderB + + val foldlMap : ('data1 * 'state -> 'data2 * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapPartial : ('data1 * 'state -> 'data2 option * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapiPartial : (int * 'data1 * 'state -> 'data2 option * 'state) + -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapConcat : ('data1 * 'state -> 'data2 list * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + val foldlMapAbort : ('data1 * 'state -> ('data2 * 'state) option) + -> 'state -> 'data1 list -> ('data2 list * 'state) option + + val search : ('a -> 'b option) -> 'a list -> 'b option + val searchi : (int * 'a -> 'b option) -> 'a list -> 'b option + + val mapi : (int * 'a -> 'b) -> 'a list -> 'b list + val mapiPartial : (int * 'a -> 'b option) -> 'a list -> 'b list + val foldli : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldri : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b + + val foldliMap : (int * 'data1 * 'state -> 'data2 * 'state) -> 'state -> 'data1 list -> 'data2 list * 'state + + val appi : (int * 'a -> unit) -> 'a list -> unit + + val appn : (int -> unit) -> int -> unit + +end diff --git a/src/list_util.sml b/src/list_util.sml new file mode 100644 index 0000000..03c9549 --- /dev/null +++ b/src/list_util.sml @@ -0,0 +1,260 @@ +(* Copyright (c) 2008, 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 ListUtil :> LIST_UTIL = struct + +structure S = Search + +fun mapConcat f = + let + fun mc acc ls = + case ls of + [] => rev acc + | h :: t => mc (List.revAppend (f h, acc)) t + in + mc [] + end + +fun mapfold f = + let + fun mf ls s = + case ls of + nil => S.Continue (nil, s) + | h :: t => + case f h s of + S.Return x => S.Return x + | S.Continue (h', s) => + case mf t s of + S.Return x => S.Return x + | S.Continue (t', s) => S.Continue (h' :: t', s) + in + mf + end + +fun mapfoldB f = + let + fun mf ctx ls s = + case ls of + nil => S.Continue (nil, s) + | h :: t => + let + val (ctx, r) = f (ctx, h) + in + case r s of + S.Return x => S.Return x + | S.Continue (h', s) => + case mf ctx t s of + S.Return x => S.Return x + | S.Continue (t', s) => S.Continue (h' :: t', s) + end + in + mf + end + +fun foldlMap f s = + let + fun fm (ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (h, s) + in + fm (h' :: ls', s') t + end + in + fm ([], s) + end + +fun foldlMapConcat f s = + let + fun fm (ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (h, s) + in + fm (List.revAppend (h', ls'), s') t + end + in + fm ([], s) + end + +fun foldlMapPartial f s = + let + fun fm (ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (h, s) + val ls' = case h' of + NONE => ls' + | SOME h' => h' :: ls' + in + fm (ls', s') t + end + in + fm ([], s) + end + +fun foldlMapiPartial f s = + let + fun fm (n, ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (n, h, s) + val ls' = case h' of + NONE => ls' + | SOME h' => h' :: ls' + in + fm (n + 1, ls', s') t + end + in + fm (0, [], s) + end + +fun foldlMapAbort f s = + let + fun fm (ls', s) ls = + case ls of + nil => SOME (rev ls', s) + | h :: t => + case f (h, s) of + NONE => NONE + | SOME (h', s') => fm (h' :: ls', s') t + in + fm ([], s) + end + +fun search f = + let + fun s ls = + case ls of + [] => NONE + | h :: t => + case f h of + NONE => s t + | v => v + in + s + end + +fun searchi f = + let + fun s n ls = + case ls of + [] => NONE + | h :: t => + case f (n, h) of + NONE => s (n + 1) t + | v => v + in + s 0 + end + +fun mapi f = + let + fun m i acc ls = + case ls of + [] => rev acc + | h :: t => m (i + 1) (f (i, h) :: acc) t + in + m 0 [] + end + +fun mapiPartial f = + let + fun m i acc ls = + case ls of + [] => rev acc + | h :: t => + m (i + 1) (case f (i, h) of + NONE => acc + | SOME v => v :: acc) t + in + m 0 [] + end + +fun appi f = + let + fun m i ls = + case ls of + [] => () + | h :: t => (f (i, h); m (i + 1) t) + in + m 0 + end + +fun foldli f = + let + fun m i acc ls = + case ls of + [] => acc + | h :: t => m (i + 1) (f (i, h, acc)) t + in + m 0 + end + +fun foldri f i ls = + let + val len = length ls + in + foldli (fn (n, x, s) => f (len - n - 1, x, s)) i (rev ls) + end + +fun foldliMap f s = + let + fun fm (n, ls', s) ls = + case ls of + nil => (rev ls', s) + | h :: t => + let + val (h', s') = f (n, h, s) + in + fm (n + 1, h' :: ls', s') t + end + in + fm (0, [], s) + end + +fun appn f n = + let + fun iter m = + if m >= n then + () + else + (f m; + iter (m + 1)) + in + iter 0 + end + +end diff --git a/src/lru_cache.sml b/src/lru_cache.sml new file mode 100644 index 0000000..f582bf6 --- /dev/null +++ b/src/lru_cache.sml @@ -0,0 +1,207 @@ +structure LruCache : sig + val cache : Cache.cache +end = struct + + +(* Mono *) + +open Mono + +val dummyLoc = ErrorMsg.dummySpan +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) +val optionStringTyp = (TOption stringTyp, dummyLoc) +fun withTyp typ = map (fn exp => (exp, typ)) + +fun ffiAppCache' (func, index, argTyps) = + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) + +fun check (index, keys) = + ffiAppCache' ("check", index, withTyp stringTyp keys) + +fun store (index, keys, value) = + ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) + +fun flush (index, keys) = + ffiAppCache' ("flush", index, withTyp optionStringTyp keys) + +fun lock (index, write) = + ffiAppCache' ((if write then "w" else "r") ^ "lock", index, []) + + +(* Cjr *) + +open Print +open Print.PD + +fun setupQuery {index, params} = + let + + val i = Int.toString index + + fun paramRepeat itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else f (n-1) ^ sep ^ itemi (Int.toString n) + in + f (params - 1) + end + + fun paramRepeatRev itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else itemi (Int.toString n) ^ sep ^ f (n-1) + in + f (params - 1) + end + + fun paramRepeatInit itemi sep = + if params = 0 then "" else sep ^ paramRepeat itemi sep + + val typedArgs = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " + + val revArgs = paramRepeatRev (fn p => "p" ^ p) ", " + + val argNums = List.tabulate (params, fn i => "p" ^ Int.toString i) + in + Print.box + [string ("static uw_Sqlcache_Cache cacheStruct" ^ i ^ " = {"), + newline, + string " .lockIn = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .lockOut = PTHREAD_RWLOCK_INITIALIZER,", + newline, + string " .table = NULL,", + newline, + string (" .numKeys = " ^ Int.toString params ^ ","), + newline, + string " .timeInvalid = 0,", + newline, + string " .timeNow = 0};", + newline, + string ("static uw_Sqlcache_Cache *cache" ^ i ^ " = &cacheStruct" ^ i ^ ";"), + newline, + newline, + + string ("static void uw_Sqlcache_rlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_rlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static void uw_Sqlcache_wlock" ^ i ^ "(uw_context ctx) {"), + newline, + string (" uw_Sqlcache_wlock(ctx, cache" ^ i ^ ");"), + newline, + string "}", + newline, + newline, + + string ("static uw_Basis_string uw_Sqlcache_check" ^ i), + string ("(uw_context ctx" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_Value *v = uw_Sqlcache_check(ctx, cache" ^ i ^ ", ks);"), + newline, + (* If the output is null, it means we had too much recursion, so it's a miss. *) + string " if (v && v->output != NULL) {", + newline, + (*string (" puts(\"SQLCACHE: hit " ^ i ^ ".\");"), + newline,*) + string " uw_write(ctx, v->output);", + newline, + string " uw_write_script(ctx, v->scriptOutput);", + newline, + string " return v->result;", + newline, + string " } else {", + newline, + (*string (" printf(\"SQLCACHE: miss " ^ i ^ " " ^ String.concatWith ", " (List.tabulate (params, fn _ => "%s")) ^ ".\\n\""), + (case argNums of + [] => Print.box [] + | _ => Print.box [string ", ", + p_list string argNums]), + string ");", + newline,*) + string " uw_recordingStart(ctx);", + newline, + string " return NULL;", + newline, + string " }", + newline, + string "}", + newline, + newline, + + string ("static uw_unit uw_Sqlcache_store" ^ i), + string ("(uw_context ctx, uw_Basis_string s" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_Value *v = malloc(sizeof(uw_Sqlcache_Value));"), + newline, + string " v->result = strdup(s);", + newline, + string " v->output = uw_recordingRead(ctx);", + newline, + string " v->scriptOutput = uw_recordingReadScript(ctx);", + newline, + (*string (" puts(\"SQLCACHE: stored " ^ i ^ ".\");"), + newline,*) + string (" uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"), + newline, + string " return uw_unit_v;", + newline, + string "}", + newline, + newline, + + string ("static uw_unit uw_Sqlcache_flush" ^ i), + string ("(uw_context ctx" ^ typedArgs ^ ") {"), + newline, + string (" char *ks[] = {" ^ revArgs ^ "};"), + newline, + string (" uw_Sqlcache_flush(ctx, cache" ^ i ^ ", ks);"), + newline, + (*string (" puts(\"SQLCACHE: flushed " ^ i ^ ".\");"), + newline,*) + string " return uw_unit_v;", + newline, + string "}", + newline, + newline] + end + +val setupGlobal = string "/* No global setup for LRU cache. */" + + +(* Bundled up. *) + +(* For now, use the toy implementation if there are no arguments. *) +fun toyIfNoKeys numKeys implLru implToy args = + if numKeys args = 0 + then implToy args + else implLru args + +val cache = + (* let *) + (* val {check = toyCheck, *) + (* store = toyStore, *) + (* flush = toyFlush, *) + (* setupQuery = toySetupQuery, *) + (* ...} = ToyCache.cache *) + (* in *) + (* {check = toyIfNoKeys (length o #2) check toyCheck, *) + (* store = toyIfNoKeys (length o #2) store toyStore, *) + (* flush = toyIfNoKeys (length o #2) flush toyFlush, *) + {check = check, store = store, flush = flush, lock = lock, + setupQuery = setupQuery, setupGlobal = setupGlobal} + (* end *) + +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml new file mode 100644 index 0000000..2caa43f --- /dev/null +++ b/src/main.mlton.sml @@ -0,0 +1,383 @@ +(* Copyright (c) 2008-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. + *) + +val socket = ".urweb_daemon" + +(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) + +exception Code of OS.Process.status + +fun oneRun args = + let + val timing = ref false + val tc = ref false + val sources = ref ([] : string list) + val demo = ref (NONE : (string * bool) option) + val tutorial = ref false + val css = ref false + + val () = (Compiler.debug := false; + Elaborate.verbose := false; + Elaborate.dumpTypes := false; + Elaborate.dumpTypesOnError := false; + Elaborate.unifyMore := false; + Compiler.dumpSource := false; + Compiler.doIflow := false; + Demo.noEmacs := false; + Settings.setDebug false) + + val () = Compiler.beforeC := MLton.GC.pack + + fun printVersion () = (print (Config.versionString ^ "\n"); + raise Code OS.Process.success) + fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); + raise Code OS.Process.success) + fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n"); + raise Code OS.Process.success) + fun printCInclude () = (print (Config.includ ^ "\n"); + raise Code OS.Process.success) + + fun doArgs args = + case args of + [] => () + | "-version" :: rest => + printVersion () + | "-numeric-version" :: rest => + printNumericVersion () + | "-css" :: rest => + (css := true; + doArgs rest) + | "-print-ccompiler" :: rest => + printCCompiler () + | "-print-cinclude" :: rest => + printCInclude () + | "-ccompiler" :: ccomp :: rest => + (Settings.setCCompiler ccomp; + doArgs rest) + | "-demo" :: prefix :: rest => + (demo := SOME (prefix, false); + doArgs rest) + | "-guided-demo" :: prefix :: rest => + (demo := SOME (prefix, true); + doArgs rest) + | "-tutorial" :: rest => + (tutorial := true; + doArgs rest) + | "-protocol" :: name :: rest => + (Settings.setProtocol name; + doArgs rest) + | "-prefix" :: prefix :: rest => + (Settings.setUrlPrefix prefix; + doArgs rest) + | "-db" :: s :: rest => + (Settings.setDbstring (SOME s); + doArgs rest) + | "-dbms" :: name :: rest => + (Settings.setDbms name; + doArgs rest) + | "-debug" :: rest => + (Settings.setDebug true; + doArgs rest) + | "-verbose" :: rest => + (Compiler.debug := true; + Elaborate.verbose := true; + doArgs rest) + | "-timing" :: rest => + (timing := true; + doArgs rest) + | "-tc" :: rest => + (tc := true; + doArgs rest) + | "-dumpTypes" :: rest => + (Elaborate.dumpTypes := true; + doArgs rest) + | "-dumpTypesOnError" :: rest => + (Elaborate.dumpTypesOnError := true; + doArgs rest) + | "-unifyMore" :: rest => + (Elaborate.unifyMore := true; + doArgs rest) + | "-dumpSource" :: rest => + (Compiler.dumpSource := true; + doArgs rest) + | "-dumpVerboseSource" :: rest => + (Compiler.dumpSource := true; + ElabPrint.debug := true; + ExplPrint.debug := true; + CorePrint.debug := true; + MonoPrint.debug := true; + doArgs rest) + | "-output" :: s :: rest => + (Settings.setExe (SOME s); + doArgs rest) + | "-js" :: s :: rest => + (Settings.setOutputJsFile (SOME s); + doArgs rest) + | "-sql" :: s :: rest => + (Settings.setSql (SOME s); + doArgs rest) + | "-static" :: rest => + (Settings.setStaticLinking true; + doArgs rest) + | "-stop" :: phase :: rest => + (Compiler.setStop phase; + doArgs rest) + | "-path" :: name :: path :: rest => + (Compiler.addPath (name, path); + doArgs rest) + | "-root" :: name :: root :: rest => + (Compiler.addModuleRoot (root, name); + doArgs rest) + | "-boot" :: rest => + (Compiler.enableBoot (); + Settings.setBootLinking true; + doArgs rest) + | "-sigfile" :: name :: rest => + (Settings.setSigFile (SOME name); + doArgs rest) + | "-iflow" :: rest => + (Compiler.doIflow := true; + doArgs rest) + | "-sqlcache" :: rest => + (Settings.setSqlcache true; + doArgs rest) + | "-heuristic" :: h :: rest => + (Sqlcache.setHeuristic h; + doArgs rest) + | "-moduleOf" :: fname :: _ => + (print (Compiler.moduleOf fname ^ "\n"); + raise Code OS.Process.success) + | "-noEmacs" :: rest => + (Demo.noEmacs := true; + doArgs rest) + | "-limit" :: class :: num :: rest => + (case Int.fromString num of + NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") + | SOME n => + if n < 0 then + raise Fail ("Invalid limit number '" ^ num ^ "'") + else + Settings.addLimit (class, n); + doArgs rest) + | "-explainEmbed" :: rest => + (JsComp.explainEmbed := true; + doArgs rest) + | arg :: rest => + (if size arg > 0 andalso String.sub (arg, 0) = #"-" then + raise Fail ("Unknown flag " ^ arg) + else + sources := arg :: !sources; + doArgs rest) + + val () = case args of + ["daemon", "stop"] => OS.Process.exit OS.Process.success + | _ => () + + val () = doArgs args + + val job = + case !sources of + [file] => file + | files => + if List.exists (fn s => s <> "-version") args then + raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: " + ^ String.concatWith ", " files) + else + printVersion () + in + case (!css, !demo, !tutorial) of + (true, _, _) => + (case Compiler.run Compiler.toCss job of + NONE => OS.Process.failure + | SOME {Overall = ov, Classes = cl} => + (app (print o Css.inheritableToString) ov; + print "\n"; + app (fn (x, (ins, ots)) => + (print x; + print " "; + app (print o Css.inheritableToString) ins; + app (print o Css.othersToString) ots; + print "\n")) cl; + OS.Process.success)) + | (_, SOME (prefix, guided), _) => + if Demo.make' {prefix = prefix, dirname = job, guided = guided} then + OS.Process.success + else + OS.Process.failure + | (_, _, true) => (Tutorial.make job; + OS.Process.success) + | _ => + if !tc then + (Compiler.check Compiler.toElaborate job; + if ErrorMsg.anyErrors () then + OS.Process.failure + else + OS.Process.success) + else if !timing then + (Compiler.time Compiler.toCjrize job; + OS.Process.success) + else + (if Compiler.compile job then + OS.Process.success + else + OS.Process.failure) + end handle Code n => n + +fun send (sock, s) = + let + val n = Socket.sendVec (sock, Word8VectorSlice.full (MLton.Word8Vector.fromPoly (Vector.map (Word8.fromInt o ord) (MLton.CharVector.toPoly s)))) + in + if n >= size s then + () + else + 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 => + 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"); + OS.Process.exit (wait ())) + else + (OS.FileSys.remove socket; + raise OS.SysErr ("", NONE)) + end handle OS.SysErr _ => OS.Process.exit (oneRun args)) diff --git a/src/marshalcheck.sig b/src/marshalcheck.sig new file mode 100644 index 0000000..fe16345 --- /dev/null +++ b/src/marshalcheck.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, 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 MARSHAL_CHECK = sig + + val check : Core.file -> unit + +end diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml new file mode 100644 index 0000000..8d7edd1 --- /dev/null +++ b/src/marshalcheck.sml @@ -0,0 +1,132 @@ +(* Copyright (c) 2009-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 MarshalCheck :> MARSHAL_CHECK = struct + +open Core + +structure U = CoreUtil +structure E = ErrorMsg + +structure PK = struct +open Order +type ord_key = string * string +fun compare ((m1, x1), (m2, x2)) = + join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) +end + +structure PS = BinarySetFn(PK) +structure PS = struct +open PS +fun toString' (m, x) = m ^ "." ^ x +fun toString set = + case PS.listItems set of + [] => "{}" + | [x] => toString' x + | x :: xs => List.foldl (fn (x, s) => s ^ ", " ^ toString' x) (toString' x) xs +end + +structure IM = IntBinaryMap + +fun check file = + let + fun kind (_, st) = st + + fun con cmap (c, st) = + case c of + CFfi mx => + if Settings.mayClientToServer mx then + st + else + PS.add (st, mx) + | CNamed n => + (case IM.find (cmap, n) of + NONE => st + | SOME st' => PS.union (st, st')) + | _ => st + + fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty + 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) + end + +end diff --git a/src/mod_db.sig b/src/mod_db.sig new file mode 100644 index 0000000..8f78f2c --- /dev/null +++ b/src/mod_db.sig @@ -0,0 +1,42 @@ +(* 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. + *) + +(* Cache of module code, with dependency information *) + +signature MOD_DB = sig + val reset : unit -> unit + + val insert : Elab.decl * Time.time -> 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 + + (* Allow undoing to snapshots after failed compilations. *) + val snapshot : unit -> unit + val revert : unit -> unit +end diff --git a/src/mod_db.sml b/src/mod_db.sml new file mode 100644 index 0000000..2d6b285 --- /dev/null +++ b/src/mod_db.sml @@ -0,0 +1,153 @@ +(* 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. + *) + +(* Cache of module code, with dependency information *) + +structure ModDb :> MOD_DB = struct + +open Elab + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure IM = IntBinaryMap + +type oneMod = {Decl : decl, + When : Time.time, + Deps : SS.set} + +val byName = ref (SM.empty : oneMod SM.map) +val byId = ref (IM.empty : string IM.map) + +fun reset () = (byName := SM.empty; + byId := IM.empty) + +fun insert (d, tm) = + let + val xn = + case #1 d of + DStr (x, n, _, _) => SOME (x, n) + | DFfiStr (x, n, _) => SOME (x, n) + | _ => NONE + in + case xn of + NONE => () + | SOME (x, n) => + let + val skipIt = + case SM.find (!byName, x) of + NONE => false + | SOME r => #When r = tm + in + if skipIt then + () + else + let + fun doMod (n', deps) = + case IM.find (!byId, n') of + NONE => deps + | SOME x' => + SS.union (deps, + SS.add (case SM.find (!byName, x') of + NONE => SS.empty + | SOME {Deps = ds, ...} => ds, x')) + + val deps = ElabUtil.Decl.fold {kind = #2, + con = fn (c, deps) => + case c of + CModProj (n', _, _) => doMod (n', deps) + | _ => deps, + exp = fn (e, deps) => + case e of + EModProj (n', _, _) => doMod (n', deps) + | _ => deps, + sgn_item = #2, + sgn = fn (sg, deps) => + case sg of + SgnProj (n', _, _) => doMod (n', deps) + | _ => deps, + str = fn (st, deps) => + case st of + StrVar n' => doMod (n', deps) + | _ => deps, + decl = fn (d, deps) => + case d of + DDatatypeImp (_, _, n', _, _, _, _) => doMod (n', deps) + | _ => deps} + SS.empty d + in + byName := SM.insert (SM.filter (fn r => if SS.member (#Deps r, x) then + case #1 (#Decl r) of + DStr (_, n', _, _) => + (byId := #1 (IM.remove (!byId, n')); + false) + | DFfiStr (_, n', _) => + (byId := #1 (IM.remove (!byId, n')); + false) + | _ => raise Fail "ModDb: Impossible decl" + else + true) (!byName), + x, + {Decl = d, + When = tm, + Deps = deps}); + byId := IM.insert (!byId, n, x) + end + end + end + +fun lookup (d : Source.decl) = + case #1 d of + Source.DStr (x, _, SOME tm, _, _) => + (case SM.find (!byName, x) of + NONE => NONE + | SOME r => + if tm = #When r then + SOME (#Decl r) + else + NONE) + | Source.DFfiStr (x, _, SOME tm) => + (case SM.find (!byName, x) of + NONE => NONE + | SOME r => + if tm = #When r then + SOME (#Decl r) + else + NONE) + | _ => NONE + +val byNameBackup = ref (!byName) +val byIdBackup = ref (!byId) + +fun snapshot () = (byNameBackup := !byName; byIdBackup := !byId) +fun revert () = (byName := !byNameBackup; byId := !byIdBackup) + +end diff --git a/src/mono.sml b/src/mono.sml new file mode 100644 index 0000000..cdadded --- /dev/null +++ b/src/mono.sml @@ -0,0 +1,171 @@ +(* Copyright (c) 2008-2010, 2013-2014, 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 Mono = struct + +type 'a located = 'a ErrorMsg.located + +datatype datatype_kind = datatype DatatypeKind.datatype_kind + +datatype typ' = + TFun of typ * typ + | TRecord of (string * typ) list + | TDatatype of int * (datatype_kind * (string * int * typ option) list) ref + | TFfi of string * string + | TOption of typ + | TList of typ + | TSource + | TSignal of typ + +withtype typ = typ' located + +datatype patCon = + PConVar of int (* constructor identifier *) + | PConFfi of {mod : string, datatyp : string, con : string, arg : typ option} + +datatype pat' = + PVar of string * typ + | PPrim of Prim.t + | PCon of datatype_kind * patCon * pat option + | PRecord of (string * pat * typ) list + | PNone of typ + | PSome of typ * pat + +withtype pat = pat' located + +datatype javascript_mode = + Attribute + | Script + | Source of typ + +datatype effect = datatype Export.effect +datatype export_kind = datatype Export.export_kind + +datatype failure_mode = datatype Settings.failure_mode + +datatype binop_intness = Int | NotInt + +datatype exp' = + EPrim of Prim.t + | ERel of int (* deBruijn index *) + | ENamed of int (* named variable *) + | ECon of datatype_kind * patCon * exp option + | ENone of typ + | ESome of typ * exp + | EFfi of string * string + | EFfiApp of string * string * (exp * typ) list + | EApp of exp * exp + | EAbs of string * typ * typ * exp + + | EUnop of string * exp + | EBinop of binop_intness * string * exp * exp + + | ERecord of (string * exp * typ) list + | EField of exp * string + + | ECase of exp * (pat * exp) list * { disc : typ, result : typ } + + | EStrcat of exp * exp + + | EError of exp * typ + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} + | ERedirect of exp * typ + + | EWrite of exp + | ESeq of exp * exp + | ELet of string * typ * exp * exp + + | EClosure of int * exp list + + | EQuery of { exps : (string * typ) list, (* name of computed field, type of field*) + tables : (string * (string * typ) list) list, + state : typ, + query : exp, (* exp of string type containing sql query *) + body : exp, + initial : exp } + | EDml of exp * failure_mode + | ENextval of exp + | ESetval of exp * exp + + | EUnurlify of exp * typ * bool + + | EJavaScript of javascript_mode * exp + + | ESignalReturn of exp + | ESignalBind of exp * exp + | ESignalSource of exp + + | EServerCall of exp * typ * effect * failure_mode + | ERecv of exp * typ + | ESleep of exp + | ESpawn of exp + +withtype exp = exp' located + +datatype policy = + PolClient of exp + | PolInsert of exp + | PolDelete of exp + | PolUpdate of exp + | PolSequence of exp + +datatype decl' = + DDatatype of (string * int * (string * int * typ option) list) list + | DVal of string * int * typ * exp * string + | DValRec of (string * int * typ * exp * string) list + | DExport of export_kind * string * int * typ list * typ * bool + + | 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} + + | DJavaScript of string + + | DCookie of string + | DStyle of string + + | DTask of exp * exp + + | DPolicy of policy + | DOnError of int + +withtype decl = decl' located + +datatype sidedness = + ServerOnly + | ServerAndPull + | ServerAndPullAndPush + +datatype dbmode = + NoDb + | OneQuery + | AnyDb + +type file = decl list * (int * sidedness * dbmode) list + +end diff --git a/src/mono_env.sig b/src/mono_env.sig new file mode 100644 index 0000000..db6fdc9 --- /dev/null +++ b/src/mono_env.sig @@ -0,0 +1,55 @@ +(* Copyright (c) 2008, 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 MONO_ENV = sig + + type env + + val empty : env + + exception UnboundRel of int + exception UnboundNamed of int + + val pushDatatype : env -> string -> int -> (string * int * Mono.typ option) list -> env + val lookupDatatype : env -> int -> string * (string * int * Mono.typ option) list + + val lookupConstructor : env -> int -> string * Mono.typ option * int + + val pushERel : env -> string -> Mono.typ -> Mono.exp option -> env + val lookupERel : env -> int -> string * Mono.typ * Mono.exp option + + val pushENamed : env -> string -> int -> Mono.typ -> Mono.exp option -> string -> env + val lookupENamed : env -> int -> string * Mono.typ * Mono.exp option * string + + val declBinds : env -> Mono.decl -> env + val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int + + val liftExpInExp : int -> Mono.exp -> Mono.exp + val subExpInExp : (int * Mono.exp) -> Mono.exp -> Mono.exp + +end diff --git a/src/mono_env.sml b/src/mono_env.sml new file mode 100644 index 0000000..0dd668e --- /dev/null +++ b/src/mono_env.sml @@ -0,0 +1,169 @@ +(* Copyright (c) 2008, 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 MonoEnv :> MONO_ENV = struct + +open Mono + +structure IM = IntBinaryMap + + +exception UnboundRel of int +exception UnboundNamed of int + +type env = { + datatypes : (string * (string * int * typ option) list) IM.map, + constructors : (string * typ option * int) IM.map, + + relE : (string * typ * exp option) list, + namedE : (string * typ * exp option * string) IM.map +} + +val empty = { + datatypes = IM.empty, + constructors = IM.empty, + + relE = [], + namedE = IM.empty +} + +fun pushDatatype (env : env) x n xncs = + {datatypes = IM.insert (#datatypes env, n, (x, xncs)), + constructors = foldl (fn ((x, n', to), constructors) => + IM.insert (constructors, n', (x, to, n))) + (#constructors env) xncs, + + relE = #relE env, + namedE = #namedE env} + +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun lookupConstructor (env : env) n = + case IM.find (#constructors env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +structure U = MonoUtil + +val liftExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | (ctx, _) => ctx} + +fun pushERel (env : env) x t eo = + {datatypes = #datatypes env, + constructors = #constructors env, + relE = (x, t, eo) :: map (fn (x, t, eo) => (x, t, Option.map (liftExpInExp 0) eo)) (#relE env), + namedE = #namedE env} + +fun lookupERel (env : env) n = + (List.nth (#relE env, n)) + handle Subscript => raise UnboundRel n + +fun pushENamed (env : env) x n t eo s = + {datatypes = #datatypes env, + constructors = #constructors env, + + relE = #relE env, + namedE = IM.insert (#namedE env, n, (x, t, eo, s))} + +fun lookupENamed (env : env) n = + case IM.find (#namedE env, n) of + NONE => raise UnboundNamed n + | SOME x => x + +fun declBinds env (d, loc) = + case d of + DDatatype dts => + foldl (fn ((x, n, xncs), env) => + let + val env = pushDatatype env x n xncs + val dt = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), loc) + in + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt NONE "" + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc) NONE "") + env xncs + end) env dts + | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s + | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis + | DExport _ => env + | DTable _ => env + | DSequence _ => env + | DView _ => env + | DDatabase _ => env + | DJavaScript _ => env + | DCookie _ => env + | DStyle _ => env + | DTask _ => env + | DPolicy _ => env + | DOnError _ => env + +fun patBinds env (p, loc) = + case p of + PVar (x, t) => pushERel env x t NONE + | PPrim _ => env + | PCon (_, _, NONE) => env + | PCon (_, _, SOME p) => patBinds env p + | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps + | PNone _ => env + | PSome (_, p) => patBinds env p + +fun patBindsN (p, loc) = + case p of + PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, NONE) => 0 + | PCon (_, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + | PNone _ => 0 + | PSome (_, p) => patBindsN p + +end diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig new file mode 100644 index 0000000..0cc7234 --- /dev/null +++ b/src/mono_fooify.sig @@ -0,0 +1,39 @@ +signature MONO_FOOIFY = sig + +(* TODO: don't expose raw references if possible. *) +val nextPvar : int ref +val pvarDefs : ((string * int * (string * int * Mono.typ option) list) list) ref + +datatype foo_kind = Attr | Url + +structure Fm : sig + type t + + type vr = string * int * Mono.typ * Mono.exp * string + + val empty : int -> t + + val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int + val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int + val enter : t -> t + (* This list should be reversed before adding to list of file declarations. *) + val decls : t -> Mono.decl list + + val freshName : t -> int * t +end + +(* General form used in [Monoize]. *) +val fooifyExp : foo_kind + -> (int -> Mono.typ * string) + -> (int -> string * (string * int * Mono.typ option) list) + -> Fm.t + -> Mono.exp * Mono.typ + -> Mono.exp * Fm.t + +(* Easy-to-use interface in [Sqlcache]. Uses [Fm.canonical]. *) +val canonicalFm : Fm.t ref (* Set at the end of [Monoize]. *) +val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp option +(* This list should be reversed before adding to list of file declarations. *) +val getNewFmDecls : unit -> Mono.decl list + +end diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml new file mode 100644 index 0000000..e64207c --- /dev/null +++ b/src/mono_fooify.sml @@ -0,0 +1,346 @@ +structure MonoFooify :> MONO_FOOIFY = struct + +open Mono + +datatype foo_kind = + Attr + | Url + +val nextPvar = ref 0 +val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list) + +structure Fm = struct + +type vr = string * int * typ * exp * string + +structure IM = IntBinaryMap + +structure M = BinaryMapFn(struct + type ord_key = foo_kind + fun compare x = + case x of + (Attr, Attr) => EQUAL + | (Attr, _) => LESS + | (_, Attr) => GREATER + + | (Url, Url) => EQUAL + end) + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + map : int IM.map M.map, + listMap : int TM.map M.map, + decls : vr list +} + +fun empty count = { + count = count, + map = M.empty, + listMap = M.empty, + decls = [] +} + +fun chooseNext count = + let + val n = !nextPvar + in + if count < n then + (count, count+1) + else + (nextPvar := n + 1; + (n, n+1)) + end + +fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []} +fun freshName {count, map, listMap, decls} = + let + val (next, count) = chooseNext count + in + (next, {count = count , map = map, listMap = listMap, decls = decls}) + end +fun decls ({decls, ...} : t) = + case decls of + [] => [] + | _ => [(DValRec decls, ErrorMsg.dummySpan)] + +fun lookup (t as {count, map, listMap, decls}) k n thunk = + let + val im = Option.getOpt (M.find (map, k), IM.empty) + in + case IM.find (im, n) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + listMap = listMap, + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +fun lookupList (t as {count, map, listMap, decls}) k tp thunk = + let + val tm = Option.getOpt (M.find (listMap, k), TM.empty) + in + case TM.find (tm, tp) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = map, + listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +end + +fun fk2s fk = + case fk of + Attr => "attr" + | Url => "url" + +fun capitalize s = + if s = "" then + s + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +structure E = ErrorMsg + +exception TypeMismatch of Fm.t * E.span +exception CantPass of Fm.t * typ +exception DontKnow of Fm.t * typ + +val dummyExp = (EPrim (Prim.Int 0), E.dummySpan) + +fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = + let + fun fooify fm (e, tAll as (t, loc)) = + case #1 e of + EClosure (fnam, [(ERecord [], _)]) => + let + val (_, s) = lookupENamed fnam + in + ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | EClosure (fnam, args) => + let + val (ft, s) = lookupENamed fnam + fun attrify (args, ft, e, fm) = + case (args, ft) of + ([], _) => (e, fm) + | (arg :: args, (TFun (t, ft), _)) => + let + val (arg', fm) = fooify fm (arg, t) + in + attrify (args, ft, + (EStrcat (e, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + arg'), loc)), loc), + fm) + end + | _ => raise TypeMismatch (fm, loc) + in + attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) + end + | _ => + case t of + 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 ((x, t) :: xts) => + let + val (se, fm) = fooify fm ((EField (e, x), loc), t) + in + foldl (fn ((x, t), (se, fm)) => + let + val (se', fm) = fooify fm ((EField (e, x), loc), t) + in + ((EStrcat (se, + (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc), + se'), loc)), loc), + fm) + end) (se, fm) xts + end + + | TDatatype (i, ref (dk, _)) => + let + fun makeDecl n fm = + let + val (x, xncs) = + case ListUtil.search (fn (x, i', xncs) => + if i' = i then + SOME (x, xncs) + else + NONE) (!pvarDefs) of + NONE => lookupDatatype i + | SOME v => v + + val (branches, fm) = + ListUtil.foldlMap + (fn ((x, n, to), fm) => + case to of + NONE => + (((PCon (dk, PConVar n, NONE), loc), + (EPrim (Prim.String (Prim.Normal, x)), loc)), + fm) + | SOME t => + let + val (arg, fm) = fooify fm ((ERel 0, loc), t) + in + (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), + arg), loc)), + fm) + end) + fm xncs + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_" ^ x, + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookup fm fk i makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | TOption t => + let + val (body, fm) = fooify fm ((ERel 0, loc), t) + in + ((ECase (e, + [((PNone t, loc), + (EPrim (Prim.String (Prim.Normal, "None")), loc)), + + ((PSome (t, (PVar ("x", t), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc), + body), loc))], + {disc = tAll, + result = (TFfi ("Basis", "string"), loc)}), loc), + fm) + end + + | TList t => + let + fun makeDecl n fm = + let + val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc) + val (arg, fm) = fooify fm ((ERel 0, loc), rt) + + val branches = [((PNone rt, loc), + (EPrim (Prim.String (Prim.Normal, "Nil")), loc)), + ((PSome (rt, (PVar ("a", rt), loc)), loc), + (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc), + arg), loc))] + + val dom = tAll + val ran = (TFfi ("Basis", "string"), loc) + in + ((fk2s fk ^ "ify_list", + n, + (TFun (dom, ran), loc), + (EAbs ("x", + dom, + ran, + (ECase ((ERel 0, loc), + branches, + {disc = dom, + result = ran}), loc)), loc), + ""), + fm) + end + + val (fm, n) = Fm.lookupList fm fk t makeDecl + in + ((EApp ((ENamed n, loc), e), loc), fm) + end + + | _ => raise DontKnow (fm, tAll) + in + fooify + end + +fun fooifyExp fk lookupENamed lookupDatatype fm exp = + fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp + handle TypeMismatch (fm, loc) => + (E.errorAt loc "Type mismatch encoding attribute"; + (dummyExp, fm)) + | CantPass (fm, typ as (_, loc)) => + (E.errorAt loc "MonoFooify: can't pass type from client to server"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + | DontKnow (fm, typ as (_, loc)) => + (E.errorAt loc "Don't know how to encode attribute/URL type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)]; + (dummyExp, fm)) + +(* Has to be set at the end of [Monoize]. *) +val canonicalFm = ref (Fm.empty 0 : Fm.t) + +fun urlify env expTyp = + let + val (exp, fm) = + fooifyExpWithExceptions + Url + (fn n => + let + val (_, t, _, s) = MonoEnv.lookupENamed env n + in + (t, s) + end) + (fn n => MonoEnv.lookupDatatype env n) + (!canonicalFm) + expTyp + in + canonicalFm := fm; + SOME exp + end + handle TypeMismatch _ => NONE + | CantPass _ => NONE + | DontKnow _ => NONE + +fun getNewFmDecls () = + let + val fm = !canonicalFm + in + canonicalFm := Fm.enter fm; + Fm.decls fm + end + +end diff --git a/src/mono_inline.sml b/src/mono_inline.sml new file mode 100644 index 0000000..d23419f --- /dev/null +++ b/src/mono_inline.sml @@ -0,0 +1,28 @@ +structure MonoInline = struct + +fun inlineFull file = + let + val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + MonoReduce.fullMode := true; + let + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + val file = MonoShake.shake file + in + file + end before + (MonoReduce.fullMode := oldFull; + Settings.setMonoInline oldInline)) + handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; + raise ex) + end + +end diff --git a/src/mono_opt.sig b/src/mono_opt.sig new file mode 100644 index 0000000..1d0fec5 --- /dev/null +++ b/src/mono_opt.sig @@ -0,0 +1,33 @@ +(* Copyright (c) 2008, 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 MONO_OPT = sig + + val optimize : Mono.file -> Mono.file + val optExp : Mono.exp -> Mono.exp + +end diff --git a/src/mono_opt.sml b/src/mono_opt.sml new file mode 100644 index 0000000..40b865b --- /dev/null +++ b/src/mono_opt.sml @@ -0,0 +1,655 @@ +(* 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 MonoOpt :> MONO_OPT = struct + +open Mono +structure U = MonoUtil + +fun typ t = t +fun decl d = d + +fun attrifyInt n = + if n < 0 then + "-" ^ Int64.toString (Int64.~ n) + else + Int64.toString n + +fun attrifyFloat n = + if n < 0.0 then + "-" ^ Real.toString (Real.~ n) + else + Real.toString n + +fun attrifyChar ch = + case ch of + #"\"" => """ + | #"&" => "&" + | ch => str ch + +val attrifyString = String.translate attrifyChar + + +val urlifyInt = attrifyInt +val urlifyFloat = attrifyFloat + +val htmlifyInt = attrifyInt +val htmlifyFloat = attrifyFloat + +val htmlifyString = String.translate (fn #"<" => "<" + | #"&" => "&" + | ch => str ch) + +fun htmlifySpecialChar ch = "&#" ^ Int.toString (ord ch) ^ ";" + +fun hexIt ch = + let + val s = Int.fmt StringCvt.HEX (ord ch) + in + case size s of + 0 => "00" + | 1 => "0" ^ s + | _ => s + end + +fun urlifyString s = + case s of + "" => "_" + | _ => + (if String.sub (s, 0) = #"_" then + "_" + else + "") + ^ String.translate (fn #" " => "+" + | ch => if Char.isAlphaNum ch then + str ch + else + "." ^ hexIt ch) s + + +fun sqlifyInt n = #p_cast (Settings.currentDbms ()) (attrifyInt n, Settings.Int) +fun sqlifyFloat n = #p_cast (Settings.currentDbms ()) (attrifyFloat n, Settings.Float) + +fun sqlifyString s = #sqlifyString (Settings.currentDbms ()) s +fun sqlifyChar ch = #sqlifyString (Settings.currentDbms ()) (str ch) + +fun unAs s = + let + fun doChars (cs, acc) = + case cs of + #"T" :: #"_" :: #"T" :: #"." :: cs => doChars (cs, acc) + | #"'" :: cs => doString (cs, #"'" :: acc) + | ch :: cs => doChars (cs, ch :: acc) + | [] => String.implode (rev acc) + + and doString (cs, acc) = + case cs of + #"\\" :: #"\\" :: cs => doString (cs, #"\\" :: #"\\" :: acc) + | #"\\" :: #"'" :: cs => doString (cs, #"'" :: #"\\" :: acc) + | #"'" :: cs => doChars (cs, #"'" :: acc) + | ch :: cs => doString (cs, ch :: acc) + | [] => String.implode (rev acc) + in + doChars (String.explode s, []) + end + +fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s +val checkData = CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #"_" + orelse ch = #"-") +val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #"+" + orelse ch = #"-" + orelse ch = #"." + orelse ch = #"%" + orelse ch = #"#") +val checkCssUrl = CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #":" + orelse ch = #"/" + orelse ch = #"." + orelse ch = #"_" + orelse ch = #"+" + orelse ch = #"-" + orelse ch = #"%" + orelse ch = #"?" + orelse ch = #"&" + orelse ch = #"=" + orelse ch = #"#") +fun checkProperty s = size s > 0 + andalso (Char.isLower (String.sub (s, 0)) orelse String.sub (s, 0) = #"_") + andalso CharVector.all (fn ch => Char.isLower ch orelse Char.isDigit ch orelse ch = #"_" orelse ch = #"-") s + +fun exp e = + case e of + EPrim (Prim.String (Prim.Html, s)) => + if CharVector.exists Char.isSpace s then + let + val (_, chs) = + CharVector.foldl (fn (ch, (lastSpace, chs)) => + let + val isSpace = Char.isSpace ch + in + if isSpace andalso lastSpace then + (true, chs) + else + (isSpace, ch :: chs) + end) + (false, []) s + in + EPrim (Prim.String (Prim.Html, String.implode (rev chs))) + end + else + e + + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) + + | EStrcat (e1, (EPrim (Prim.String (_, "")), _)) => #1 e1 + | EStrcat ((EPrim (Prim.String (_, "")), _), e2) => #1 e2 + + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => + let + val s = + if size s1 > 0 andalso size s2 > 0 + andalso Char.isSpace (String.sub (s1, size s1 - 1)) + andalso Char.isSpace (String.sub (s2, 0)) then + s1 ^ String.extract (s2, 1, NONE) + else + s1 ^ s2 + in + EPrim (Prim.String (Prim.Html, s)) + end + + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => + EPrim (Prim.String (Prim.Normal, s1 ^ s2)) + + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EStrcat ((EPrim (Prim.String (Prim.Html, s2)), _), rest), _)) => + let + val s = + if size s1 > 0 andalso size s2 > 0 + andalso Char.isSpace (String.sub (s1, size s1 - 1)) + andalso Char.isSpace (String.sub (s2, 0)) then + s1 ^ String.extract (s2, 1, NONE) + else + s1 ^ s2 + in + EStrcat ((EPrim (Prim.String (Prim.Html, s)), loc), rest) + end + + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EStrcat ((EPrim (Prim.String (_, s2)), _), rest), _)) => + EStrcat ((EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), rest) + + | EStrcat ((EStrcat (e1, e2), loc), e3) => + optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc) + + | EWrite (EStrcat (e1, e2), loc) => + ESeq ((optExp (EWrite e1, loc), loc), + (optExp (EWrite e2, loc), loc)) + + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (EWrite (EPrim (Prim.String (_, s2)), _), _)) => + EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc) + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (ESeq ((EWrite (EPrim (Prim.String (_, s2)), _), _), + e), _)) => + ESeq ((EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), loc), + e) + + | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifySpecialChar ch)) + | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) => + EFfiApp ("Basis", "htmlifySpecialChar_w", [e]) + + | EWrite (EFfiApp ("Basis", "intToString", [e]), _) => + EFfiApp ("Basis", "htmlifyInt_w", [e]) + | EApp ((EFfi ("Basis", "intToString"), loc), e) => + EFfiApp ("Basis", "intToString", [(e, (TFfi ("Basis", "int"), loc))]) + + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyInt n)) + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) => + EFfiApp ("Basis", "htmlifyInt", es) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), + (EPrim (Prim.Int n), _)), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyInt n)) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))]) + | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) => + EFfiApp ("Basis", "htmlifyInt_w", [e]) + + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) => + EFfiApp ("Basis", "htmlifyFloat", es) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), + (EPrim (Prim.Float n), _)), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))]) + | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) => + EFfiApp ("Basis", "htmlifyFloat_w", [e]) + + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", + [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) => + EPrim (Prim.String (Prim.Html, "True")) + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", + [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) => + EPrim (Prim.String (Prim.Html, "False")) + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) => + EFfiApp ("Basis", "htmlifyBool", es) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) => + EPrim (Prim.String (Prim.Html, "True")) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) => + EPrim (Prim.String (Prim.Html, "False")) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))]) + | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) => + EFfiApp ("Basis", "htmlifyBool_w", [e]) + + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "timeToString"), _), e), loc), _)]) => + EFfiApp ("Basis", "htmlifyTime", [(e, (TFfi ("Basis", "time"), loc))]) + | EFfiApp ("Basis", "htmlifyString_w", [((EApp ((EFfi ("Basis", "timeToString"), loc), e), _), _)]) => + EFfiApp ("Basis", "htmlifyTime_w", [(e, (TFfi ("Basis", "time"), loc))]) + | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => + EFfiApp ("Basis", "htmlifyTime_w", [e]) + + | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyString s)) + | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) + | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => + EFfiApp ("Basis", "htmlifyString_w", [e]) + | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String (_, s)), loc), _)]) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) + + | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) => + EFfiApp ("Basis", "htmlifySource_w", [e]) + + | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyInt n)) + | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyInt n)), loc) + | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => + EFfiApp ("Basis", "attrifyInt_w", [e]) + + | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyFloat n)) + | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyFloat n)), loc) + | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => + EFfiApp ("Basis", "attrifyFloat_w", [e]) + + | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyString s)) + | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyString s)), loc) + | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => + EFfiApp ("Basis", "attrifyString_w", [e]) + + | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyChar s)) + | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyChar s)), loc) + | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => + EFfiApp ("Basis", "attrifyChar_w", [e]) + + | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, s)) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, s)), loc) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => + EFfiApp ("Basis", "attrifyString_w", [e]) + + | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyInt n)) + | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyInt n)), loc) + | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) => + EFfiApp ("Basis", "urlifyInt_w", [e]) + + | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyFloat n)) + | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyFloat n)), loc) + | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) => + EFfiApp ("Basis", "urlifyFloat_w", [e]) + + | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyString s)) + | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (Prim.Normal, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyString s)), loc) + | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => + EFfiApp ("Basis", "urlifyString_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), _), _)]) => + EPrim (Prim.String (Prim.Normal, "0")) + | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, "1")), loc) + | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, "0")), loc) + | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) => + EFfiApp ("Basis", "urlifyBool_w", [e]) + + | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) => + EPrim (Prim.String (Prim.Normal, "NULL")) + | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) + + | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyFloat n)) + | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) => + optExp (ECase (b, + [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), + (EPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc)), + ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), + (EPrim (Prim.String (Prim.Normal, #falseString (Settings.currentDbms ()))), loc))], + {disc = (TFfi ("Basis", "bool"), loc), + result = (TFfi ("Basis", "string"), loc)}), loc) + | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String (_, n)), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyString n)) + | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyChar n)) + + | EWrite (ECase (discE, pes, {disc, ...}), loc) => + optExp (ECase (discE, + map (fn (p, e) => (p, (EWrite e, loc))) pes, + {disc = disc, + result = (TRecord [], loc)}), loc) + + | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) => + let + fun doBody e = + case #1 e of + EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body + | _ => (EApp (e, arg), loc) + in + optExp (ECase (discE, + map (fn (p, e) => (p, doBody e)) pes, + {disc = disc, + result = ran}), loc) + end + + | EWrite (EQuery {exps, tables, state, query, + initial = (EPrim (Prim.String (k, "")), _), + body = (EStrcat ((EPrim (Prim.String (_, s)), _), + (EStrcat ((ERel 0, _), + e'), _)), _)}, loc) => + if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then + EQuery {exps = exps, tables = tables, query = query, + state = (TRecord [], loc), + initial = (ERecord [], loc), + body = (optExp (EWrite e', loc), loc)} + else + e + + | EWrite (EQuery {exps, tables, state, query, + initial = (EPrim (Prim.String (_, "")), _), + body}, loc) => + let + fun passLets (depth, (e', _), lets) = + case e' of + EStrcat ((ERel x, _), e'') => + if x = depth then + let + val body = (optExp (EWrite e'', loc), loc) + val body = foldl (fn ((x, t, e'), e) => + (ELet (x, t, e', e), loc)) + body lets + in + EQuery {exps = exps, tables = tables, query = query, + state = (TRecord [], loc), + initial = (ERecord [], loc), + body = body} + end + else + e + | ELet (x, t, e', e'') => + passLets (depth + 1, e'', (x, t, e') :: lets) + | _ => e + in + passLets (0, body, []) + end + + (*| EWrite (EQuery {exps, tables, state, query, + initial = (EPrim (Prim.String ""), _), + body = (EStrcat ((ERel 0, _), e'), _)}, loc) => + EQuery {exps = exps, tables = tables, query = query, + state = (TRecord [], loc), + initial = (ERecord [], loc), + body = (optExp (EWrite e', loc), loc)}*) + + | EWrite (ELet (x, t, e1, e2), loc) => + optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) + + | EWrite (EPrim (Prim.String (_, "")), loc) => + ERecord [] + + | ESignalBind ((ESignalReturn e1, loc), e2) => + optExp (EApp (e2, e1), loc) + + | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkData s then + () + else + ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s); + se) + + | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkUrl s then + () + else + ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); + se) + | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkUrl s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkMime s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'"); + se) + | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkMime s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkAtom s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'"); + se) + | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkCssUrl s then + () + else + ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'"); + se) + | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if checkProperty s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'"); + se) + | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkRequestHeader s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'"); + se) + | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkRequestHeader s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkResponseHeader s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'"); + se) + | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkResponseHeader s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkEnvVar s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'"); + se) + | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkEnvVar s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "blessMeta", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkMeta s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMeta'"); + se) + | EFfiApp ("Basis", "checkMeta", [((se as EPrim (Prim.String (_, s)), loc), _)]) => + (if Settings.checkMeta s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) + + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => + let + fun uwify (cs, acc) = + case cs of + [] => String.concat (rev acc) + | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc) + | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc) + | #"'" :: cs => + let + fun waitItOut (cs, acc) = + case cs of + [] => raise Fail "MonoOpt: Unterminated SQL string literal" + | #"'" :: cs => uwify (cs, "'" :: acc) + | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) + | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) + | c :: cs => waitItOut (cs, str c :: acc) + in + waitItOut (cs, "'" :: acc) + end + | c :: cs => uwify (cs, str c :: acc) + + val s = case String.explode s of + #"_" :: cs => uwify (cs, ["uw_"]) + | cs => uwify (cs, []) + in + EPrim (Prim.String (Prim.Normal, s)) + end + + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => + let + fun uwify (cs, acc) = + case cs of + [] => String.concat (rev acc) + | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc) + | #"'" :: cs => + let + fun waitItOut (cs, acc) = + case cs of + [] => raise Fail "MonoOpt: Unterminated SQL string literal" + | #"'" :: cs => uwify (cs, "'" :: acc) + | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) + | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) + | c :: cs => waitItOut (cs, str c :: acc) + in + waitItOut (cs, "'" :: acc) + end + | c :: cs => uwify (cs, str c :: acc) + + val s = uwify (String.explode s, []) + in + EPrim (Prim.String (Prim.Normal, s)) + end + + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, unAs s)) + | EFfiApp ("Basis", "unAs", [(e', _)]) => + let + fun parts (e as (_, loc)) = + case #1 e of + EStrcat (s1, s2) => + (case (parts s1, parts s2) of + (SOME p1, SOME p2) => SOME (p1 @ p2) + | _ => NONE) + | EPrim (Prim.String (_, s)) => SOME [(EPrim (Prim.String (Prim.Normal, unAs s)), loc)] + | EFfiApp ("Basis", f, [_]) => + if String.isPrefix "sqlify" f then + SOME [e] + else + NONE + | _ => NONE + in + case parts e' of + SOME [e] => #1 e + | SOME es => + (case rev es of + (e as (_, loc)) :: es => #1 (foldl (fn (e, es) => (EStrcat (e, es), loc)) e es) + | [] => raise Fail "MonoOpt impossible nil") + | NONE => e + end + + | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) => + EPrim (Prim.String (Prim.Normal, str ch)) + | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => + EFfiApp ("Basis", "attrifyChar", [e]) + | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => + EFfiApp ("Basis", "attrifyChar_w", [e]) + | EWrite (EFfiApp ("Basis", "str1", [e]), _) => + EFfiApp ("Basis", "writec", [e]) + + | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) + | EBinop (_, "-", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.- (n1, n2))) + | EBinop (_, "*", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.* (n1, n2))) + + | _ => e + +and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) + +val optimize = U.File.map {typ = typ, exp = exp, decl = decl} + +val optExp = U.Exp.map {typ = typ, exp = exp} + +end diff --git a/src/mono_print.sig b/src/mono_print.sig new file mode 100644 index 0000000..405ff41 --- /dev/null +++ b/src/mono_print.sig @@ -0,0 +1,38 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web monomorphic language *) + +signature MONO_PRINT = sig + val p_typ : MonoEnv.env -> Mono.typ Print.printer + val p_exp : MonoEnv.env -> Mono.exp Print.printer + val p_decl : MonoEnv.env -> Mono.decl Print.printer + val p_file : MonoEnv.env -> Mono.file Print.printer + + val debug : bool ref +end + diff --git a/src/mono_print.sml b/src/mono_print.sml new file mode 100644 index 0000000..a3b55ec --- /dev/null +++ b/src/mono_print.sml @@ -0,0 +1,554 @@ +(* Copyright (c) 2008, 2013, 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. + *) + +(* Pretty-printing monomorphic Ur/Web *) + +structure MonoPrint :> MONO_PRINT = struct + +open Print.PD +open Print + +open Mono + +structure E = MonoEnv + +val debug = ref false + +val dummyt = (TRecord [], ErrorMsg.dummySpan) + +fun p_typ' par env (t, _) = + case t of + TFun (t1, t2) => parenIf par (box [p_typ' true env t1, + space, + string "->", + space, + p_typ env t2]) + | TRecord xcs => box [string "{", + p_list (fn (x, t) => + box [string x, + space, + string ":", + space, + p_typ env t]) xcs, + string "}"] + | TDatatype (n, ref (dk, _)) => + ((if !debug then + string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n ^ "[" + ^ (case dk of + Option => "Option" + | Enum => "Enum" + | Default => "Default") + ^ "]") + else + string (#1 (E.lookupDatatype env n))) + handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n)) + | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] + | TOption t => box [string "option(", + p_typ env t, + string ")"] + | TList t => box [string "list(", + p_typ env t, + string ")"] + | TSource => string "source" + | TSignal t => box [string "signal(", + p_typ env t, + string ")"] + +and p_typ env = p_typ' false env + +fun p_enamed env n = + (if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n) + +fun p_con_named env n = + (if !debug then + string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupConstructor env n))) + handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n) + +fun p_patCon env pc = + case pc of + PConVar n => p_con_named env n + | PConFfi {mod = m, con, ...} => box [string "FFIC(", + string m, + string ".", + string con, + string ")"] + +fun p_pat' par env (p, _) = + case p of + PVar (s, _) => string s + | PPrim p => Prim.p_t p + | PCon (_, n, NONE) => p_patCon env n + | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n, + space, + p_pat' true env p]) + | PRecord xps => + box [string "{", + p_list_sep (box [string ",", space]) (fn (x, p, _) => + box [string x, + space, + string "=", + space, + p_pat env p]) xps, + string "}"] + | PNone _ => string "None" + | PSome (t, p) => + if !debug then + box [string "Some[", + p_typ env t, + string "]", + space, + p_pat' true env p] + else + box [string "Some", + space, + p_pat' true env p] + +and p_pat x = p_pat' false x + +fun p_mode env m = + case m of + Attribute => string "Attribute" + | Script => string "Script" + | Source t => box [string "Source", space, p_typ env t] + +fun p_exp' par env (e, _) = + case e of + EPrim p => Prim.p_t p + | ERel n => + ((if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n))) + handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) + | ENamed n => p_enamed env n + | ECon (_, pc, NONE) => p_patCon env pc + | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc, + space, + p_exp' true env e]) + | ENone _ => string "None" + | ESome (_, e) => parenIf par (box [string "Some", + space, + p_exp' true env e]) + + | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] + | EFfiApp (m, x, es) => box [string "FFI(", + string m, + string ".", + string x, + string "(", + p_list (p_exp env o #1) es, + string "))"] + | EApp (e1, e2) => parenIf par (box [p_exp env e1, + space, + p_exp' true env e2]) + | EAbs (x, t, _, e) => parenIf true (box [string "fn", + space, + string x, + space, + string ":", + space, + p_typ env t, + space, + string "=>", + space, + p_exp (E.pushERel env x t NONE) e]) + + | EUnop (s, e) => parenIf true (box [string s, + space, + p_exp' true env e]) + | EBinop (_, s, e1, e2) => parenIf true (box [p_exp' true env e1, + space, + string s, + space, + p_exp' true env e2]) + + | ERecord xes => box [string "{", + p_list (fn (x, e, _) => + box [string x, + space, + string "=", + space, + p_exp env e]) xes, + string "}"] + | EField (e, x) => + box [p_exp' true env e, + string ".", + string x] + + | ECase (e, pes, {result, ...}) => parenIf true (box [string "case", + space, + p_exp env e, + space, + if !debug then + box [string "return", + space, + p_typ env result, + space] + else + box [], + string "of", + space, + p_list_sep (box [space, string "|", space]) + (fn (p, e) => box [p_pat env p, + space, + string "=>", + space, + p_exp (E.patBinds env p) e]) + pes]) + + | EError (e, t) => box [string "(error", + space, + p_exp env e, + space, + string ":", + space, + p_typ env t, + string ")"] + | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "(blob", + space, + p_exp env blob, + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] + | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob", + space, + string "<page>", + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] + | ERedirect (e, t) => box [string "(redirect", + space, + p_exp env e, + space, + string ":", + space, + p_typ env t, + string ")"] + + | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1, + space, + string "^", + space, + p_exp env e2]) + + | EWrite e => box [string "write(", + p_exp env e, + string ")"] + + | ESeq (e1, e2) => box [string "(", + p_exp env e1, + string ";", + space, + p_exp env e2, + string ")"] + | ELet (x, t, e1, e2) => box [string "(let", + space, + string x, + space, + string ":", + space, + p_typ env t, + space, + string "=", + space, + string "(", + p_exp env e1, + string ")", + space, + string "in", + space, + string "(", + p_exp (E.pushERel env x t NONE) e2, + string "))"] + + | EClosure (n, es) => box [string "CLOSURE(", + p_enamed env n, + p_list_sep (string "") (fn e => box [string ", ", + p_exp env e]) es, + string ")"] + + | EQuery {exps, tables, state, query, body, initial} => + box [string "query[", + p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, + string "] [", + p_list (fn (x, xts) => box [string x, + space, + string ":", + space, + string "{", + p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts, + string "}"]) tables, + string "] [", + p_typ env state, + string "]", + space, + p_exp env query, + space, + string "initial", + space, + p_exp env initial, + space, + string "in", + space, + p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body] + | EDml (e, _) => box [string "dml(", + p_exp env e, + string ")"] + | ENextval e => box [string "nextval(", + p_exp env e, + string ")"] + | ESetval (e1, e2) => box [string "setval(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] + | EUnurlify (e, _, _) => box [string "unurlify(", + p_exp env e, + string ")"] + | EJavaScript (m, e) => box [string "JavaScript(", + p_mode env m, + string ",", + space, + p_exp env e, + string ")"] + + | ESignalReturn e => box [string "Return(", + p_exp env e, + string ")"] + | ESignalBind (e1, e2) => box [string "Bind(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] + | ESignalSource e => box [string "Source(", + p_exp env e, + string ")"] + + | EServerCall (n, _, _, _) => box [string "Server(", + p_exp env n, + string ")"] + | ERecv (n, _) => box [string "Recv(", + p_exp env n, + string ")"] + | ESleep n => box [string "Sleep(", + p_exp env n, + string ")"] + | ESpawn n => box [string "Spawn(", + p_exp env n, + string ")"] + +and p_exp env = p_exp' false env + +fun p_vali env (x, n, t, e, s) = + let + val xp = if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + in + box [xp, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_typ env t, + space, + string "=", + space, + p_exp env e] + end + +fun p_datatype env (x, n, cons) = + let + val env = E.pushDatatype env x n cons + in + box [if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x, + space, + string "=", + space, + p_list_sep (box [space, string "|", space]) + (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x + | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n)) + else string x, space, string "of", space, p_typ env t]) + cons] + end + +fun p_policy env pol = + case pol of + PolClient e => box [string "sendClient", + space, + p_exp env e] + | PolInsert e => box [string "mayInsert", + space, + p_exp env e] + | PolDelete e => box [string "mayDelete", + space, + p_exp env e] + | PolUpdate e => box [string "mayUpdate", + space, + p_exp env e] + | PolSequence e => box [string "sendOwnIds", + space, + p_exp env e] + +fun p_decl env (dAll as (d, _) : decl) = + case d of + DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] + | DVal vi => box [string "val", + space, + p_vali env vi] + | DValRec vis => + let + val env = E.declBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_vali env) vis] + end + + | DExport (ek, s, n, ts, t, _) => box [string "export", + space, + Export.p_export_kind ek, + space, + p_enamed env n, + space, + string "as", + space, + string s, + p_list_sep (string "") (fn t => box [space, + string "(", + p_typ env t, + string ")"]) ts, + space, + string "->", + space, + p_typ env t] + + | DTable (s, xts, pe, ce) => box [string "(* SQL table ", + string s, + space, + string ":", + space, + p_list (fn (x, t) => box [string x, + space, + string ":", + space, + p_typ env t]) xts, + space, + string "keys", + space, + p_exp env pe, + space, + string "constraints", + space, + p_exp env ce, + space, + string "*)"] + | DSequence s => box [string "(* SQL sequence ", + string s, + string "*)"] + | DView (s, _, e) => box [string "(* SQL view ", + string s, + space, + string "as", + 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 ")"] + | DJavaScript s => box [string "JavaScript(", + string s, + string ")"] + + | DCookie s => box [string "cookie", + space, + string s] + | DStyle s => box [string "style", + space, + string s] + | DTask (e1, e2) => box [string "task", + space, + p_exp env e1, + space, + string "=", + space, + p_exp env e2] + | DPolicy p => box [string "policy", + space, + p_policy env p] + | DOnError _ => string "ONERROR" + +fun p_file env (file, _) = + let + val (pds, _) = ListUtil.foldlMap (fn (d, env) => + (p_decl env d, + E.declBinds env d)) + env file + in + p_list_sep newline (fn x => x) pds + end + +end diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig new file mode 100644 index 0000000..8990b21 --- /dev/null +++ b/src/mono_reduce.sig @@ -0,0 +1,40 @@ +(* Copyright (c) 2008, 2013, 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. + *) + +(* Simplify a Mono program algebraically *) + +signature MONO_REDUCE = sig + + val reduce : Mono.file -> Mono.file + + val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + + val impure : Mono.exp -> bool + + val fullMode : bool ref + +end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml new file mode 100644 index 0000000..5bcb6f5 --- /dev/null +++ b/src/mono_reduce.sml @@ -0,0 +1,924 @@ +(* Copyright (c) 2008, 2013-2014, 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. + *) + +(* Simplify a Mono program algebraically *) + +structure MonoReduce :> MONO_REDUCE = struct + +open Mono + +val fullMode = ref false + +structure E = MonoEnv +structure U = MonoUtil + +structure IM = IntBinaryMap +structure IS = IntBinarySet + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +structure SLS = BinarySetFn(struct + type ord_key = string list + val compare = Order.joinL String.compare + end) + + + +fun simpleTypeImpure tsyms = + U.Typ.exists (fn TFun _ => true + | TDatatype (n, _) => IS.member (tsyms, n) + | _ => false) + +fun simpleImpure isGlobal (tsyms, syms) = + U.Exp.existsB {typ = fn _ => false, + exp = fn (env, e) => + case e of + EWrite _ => true + | EQuery _ => true + | EDml _ => true + | ENextval _ => true + | ESetval _ => true + | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) + | EServerCall _ => true + | ERecv _ => true + | ESleep _ => true + | ENamed n => IS.member (syms, n) + | ERel n => + let + val (_, t, _) = E.lookupERel env n + in + simpleTypeImpure tsyms t + end + | EApp _ => not isGlobal + | _ => false, + bind = fn (env, b) => + case b of + U.Exp.RelE (x, t) => E.pushERel env x t NONE + | _ => env} + +fun impure (e, _) = + case e of + EWrite _ => true + | EQuery _ => true + | EDml _ => true + | ENextval _ => true + | ESetval _ => true + | EUnurlify (e, _, _) => impure e + | EAbs _ => false + + | EPrim _ => false + | ERel _ => false + | ENamed _ => false + | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e) + | ENone _ => false + | ESome (_, e) => impure e + | EFfi _ => false + | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) + | EApp ((EFfi _, _), _) => false + | EApp _ => true + + | EUnop (_, e) => impure e + | EBinop (_, _, e1, e2) => impure e1 orelse impure e2 + + | ERecord xes => List.exists (fn (_, e, _) => impure e) xes + | EField (e, _) => impure e + + | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes + + | EError _ => true + | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2 + | ERedirect (e, _) => impure e + + | EStrcat (e1, e2) => impure e1 orelse impure e2 + + | ESeq (e1, e2) => impure e1 orelse impure e2 + | ELet (_, _, e1, e2) => impure e1 orelse impure e2 + + | EClosure (_, es) => List.exists impure es + | EJavaScript (_, e) => impure e + | ESignalReturn e => impure e + | ESignalBind (e1, e2) => impure e1 orelse impure e2 + | ESignalSource e => impure e + | EServerCall _ => true + | ERecv _ => true + | ESleep _ => true + | ESpawn _ => true + +val liftExpInExp = Monoize.liftExpInExp + +fun multiLift n e = + case n of + 0 => e + | _ => multiLift (n - 1) (liftExpInExp 0 e) + +val subExpInExp' = + U.Exp.mapB {typ = fn t => t, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | (ctx, _) => ctx} + +fun subExpInExp (n, e1) e2 = + let + val r = subExpInExp' (n, e1) e2 + in + (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1), + ("e2", MonoPrint.p_exp MonoEnv.empty e2), + ("r", MonoPrint.p_exp MonoEnv.empty r)];*) + r + end + +fun typ c = c + +val swapExpVars = + U.Exp.mapB {typ = fn t => t, + exp = fn lower => fn e => + case e of + ERel xn => + if xn = lower then + ERel (lower + 1) + else if xn = lower + 1 then + ERel lower + else + e + | _ => e, + bind = fn (lower, U.Exp.RelE _) => lower+1 + | (lower, _) => lower} + +val swapExpVarsPat = + U.Exp.mapB {typ = fn t => t, + exp = fn (lower, len) => fn e => + case e of + ERel xn => + if xn = lower then + ERel (lower + len) + else if xn >= lower + 1 andalso xn < lower + 1 + len then + ERel (xn - 1) + else + e + | _ => e, + bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) + | (st, _) => st} + +datatype result = Yes of (string * typ * exp) list | No | Maybe + +fun match (env, p : pat, e : exp) = + case (#1 p, #1 e) of + (PVar (x, t), _) => Yes ((x, t, e) :: env) + + | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => + if String.isPrefix s' s then + Maybe + else + No + + | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) => + if String.isSuffix s' s then + Maybe + else + No + + | (PPrim p, EPrim p') => + if Prim.equal (p, p') then + Yes env + else + No + + | (PPrim (Prim.String (_, s)), _) => + let + fun lengthLb (e : exp) = + case #1 e of + EStrcat (e1, e2) => lengthLb e1 + lengthLb e2 + | EPrim (Prim.String (_, s)) => size s + | _ => 0 + in + if lengthLb e > size s then + No + else + Maybe + end + + | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) => + if n1 = n2 then + case (po, eo) of + (NONE, NONE) => Yes env + | (SOME p, SOME e) => match (env, p, e) + | _ => Maybe + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) => + if m1 = m2 andalso con1 = con2 then + Yes env + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) => + if m1 = m2 andalso con1 = con2 then + match (env, p, e) + else + No + + | (PRecord xps, ERecord xes) => + let + fun consider (xps, env) = + case xps of + [] => Yes env + | (x, p, _) :: rest => + case List.find (fn (x', _, _) => x' = x) xes of + NONE => No + | SOME (_, e, _) => + case match (env, p, e) of + No => No + | Maybe => Maybe + | Yes env => consider (rest, env) + in + consider (xps, env) + end + + | (PNone _, ENone _) => Yes env + | (PNone _, ESome _) => No + | (PSome (_, p), ESome (_, e)) => match (env, p, e) + | (PSome _, ENone _) => No + + | _ => Maybe + +datatype event = + WritePage + | ReadDb + | WriteDb + | ReadCookie + | WriteCookie + | UseRel + | Unsure + | Abort + +fun p_event e = + let + open Print.PD + in + case e of + WritePage => string "WritePage" + | ReadDb => string "ReadDb" + | WriteDb => string "WriteDb" + | ReadCookie => string "ReadCookie" + | WriteCookie => string "WriteCookie" + | UseRel => string "UseRel" + | Unsure => string "Unsure" + | Abort => string "Abort" + end + +val p_events = Print.p_list p_event + +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 + | PNone _ => 0 + | PSome (_, p) => patBinds p + +val countFree = U.Exp.foldB {typ = fn (_, n) => n, + exp = fn (x, e, n) => + case e of + ERel x' => if x = x' then n + 1 else n + | _ => n, + bind = fn (n, b) => + case b of + U.Exp.RelE _ => n + 1 + | _ => n} + +val freeInAbs = U.Exp.existsB {typ = fn _ => false, + exp = fn (n, e) => + case e of + EAbs (_, _, _, b) => countFree n 0 b > 0 + | EJavaScript (_, b) => countFree n 0 b > 0 + | _ => false, + bind = fn (n, b) => + case b of + U.Exp.RelE _ => n + 1 + | _ => n} 0 + +val yankedCase = ref false + +fun reduce' (file : file) = + let + val (timpures, impures, absCounts) = + foldl (fn ((d, _), (timpures, impures, absCounts)) => + let + fun countAbs env e = + case #1 e of + EAbs (x, t, _, e) => 1 + countAbs (E.pushERel env x t NONE) e + | _ => + let + fun remaining e = + case #1 e of + ENamed n => IM.find (absCounts, n) + | EApp (e, arg) => + if simpleImpure true (timpures, impures) env arg then + NONE + else + (case remaining e of + NONE => NONE + | SOME n => if n > 0 then + SOME (n - 1) + else + NONE) + | _ => NONE + in + getOpt (remaining e, 0) + end + in + case d of + DDatatype dts => + (if List.exists (fn (_, _, cs) => + List.exists (fn (_, _, NONE) => false + | (_, _, SOME t) => simpleTypeImpure timpures t) cs) + dts then + IS.addList (timpures, map #2 dts) + else + timpures, + impures, + absCounts) + | DVal (_, n, _, e, _) => + (timpures, + if simpleImpure true (timpures, impures) E.empty e then + IS.add (impures, n) + else + impures, + IM.insert (absCounts, n, countAbs E.empty e)) + | DValRec vis => + (timpures, + if List.exists (fn (_, _, _, e, _) => simpleImpure true (timpures, impures) E.empty e) vis then + foldl (fn ((_, n, _, _, _), impures) => + IS.add (impures, n)) impures vis + else + impures, + foldl (fn ((x, n, _, e, _), absCounts) => + IM.insert (absCounts, n, countAbs E.empty e)) + absCounts vis) + | _ => (timpures, impures, absCounts) + end) + (IS.empty, IS.empty, IM.empty) (#1 file) + + val uses = U.File.fold {typ = fn (_, m) => m, + exp = fn (e, m) => + case e of + ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0)) + | _ => m, + decl = fn (_, m) => m} + IM.empty file + + val size = U.Exp.fold {typ = fn (_, n) => n, + exp = fn (_, n) => n + 1} 0 + + val functionInside' = U.Typ.exists (fn c => case c of + TFun _ => true + | _ => false) + + fun functionInside t = + case #1 t of + TFun (t1, t2) => functionInside' t1 orelse functionInside t2 + | _ => functionInside' t + + fun mayInline (n, e, t, s) = + case IM.find (uses, n) of + NONE => false + | SOME count => not (Settings.checkNeverInline s) + andalso (count <= 1 + orelse size e <= Settings.getMonoInline () + orelse functionInside t + orelse Settings.checkAlwaysInline s) + + fun summarize d (e, _) = + let + val s = + case e of + EPrim _ => [] + | ERel n => if n = d then [UseRel] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "get_cookie", [(e, _)]) => + summarize d e @ [ReadCookie] + | EFfiApp ("Basis", "set_cookie", es) => + List.concat (map (summarize d o #1) es) @ [WriteCookie] + | EFfiApp ("Basis", "clear_cookie", es) => + List.concat (map (summarize d o #1) es) @ [WriteCookie] + | EFfiApp (m, x, es) => + if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then + List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then + WritePage + else + Unsure] + else + List.concat (map (summarize d o #1) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => + let + fun unravel (e, passed, ls) = + case e of + ENamed n => + let + val ls = rev ls + in + if IS.member (impures, n) then + case IM.find (absCounts, n) of + NONE => [Unsure] + | SOME len => + if passed < len then + ls + else + ls @ [Unsure] + else + ls + end + | ERel n => List.revAppend (ls, + if n = d then + [UseRel, Unsure] + else + [Unsure]) + | EApp (f, x) => + unravel (#1 f, passed + 1, List.revAppend (summarize d x, + ls)) + | EError _ => [Abort] + | _ => [Unsure] + in + unravel (e, 0, []) + end + + | EAbs _ => [] + + | EUnop (_, e) => summarize d e + | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2 + + | ERecord xets => List.concat (map (summarize d o #2) xets) + | EField (e, _) => summarize d e + + | ECase (e, pes, _) => + let + val lss = map (fn (p, e) => summarize (if d = ~1 then ~1 else d + patBinds p) e) pes + + fun splitRel ls acc = + case ls of + [] => (acc, false, ls) + | UseRel :: ls => (acc, true, ls) + | v :: ls => splitRel ls (v :: acc) + + val (pre, used, post) = foldl (fn (ls, (pre, used, post)) => + let + val (pre', used', post') = splitRel ls [] + in + (pre' @ pre, used' orelse used, post' @ post) + end) + ([], false, []) lss + in + summarize d e + @ pre + @ (if used then [UseRel] else []) + @ post + end + | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 + + | EError (e, _) => summarize d e @ [Abort] + | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort] + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] + | ERedirect (e, _) => summarize d e @ [Abort] + + | EWrite e => summarize d e @ [WritePage] + + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 + | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2 + + | EClosure (_, es) => List.concat (map (summarize d) es) + + | EQuery {query, body, initial, ...} => + List.concat [summarize d query, + summarize d initial, + [ReadDb], + summarize (if d = ~1 then ~1 else d + 2) body] + + | EDml (e, _) => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] + | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb] + | EUnurlify (e, _, _) => summarize d e + | EJavaScript (_, e) => summarize d e + | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 + | ESignalSource e => summarize d e + + | EServerCall (e, _, _, _) => summarize d e @ [Unsure] + | ERecv (e, _) => summarize d e @ [Unsure] + | ESleep e => summarize d e @ [Unsure] + | ESpawn e => summarize d e @ [Unsure] + in + (*Print.prefaces "Summarize" + [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), + ("d", Print.PD.string (Int.toString d)), + ("s", p_events s)];*) + s + end + + val impure = fn env => fn e => + simpleImpure false (timpures, impures) env e andalso impure e + andalso not (List.null (summarize ~1 e)) + + fun passive (e : exp) = + case #1 e of + EPrim _ => true + | ERel _ => true + | ENamed _ => true + | ECon (_, _, NONE) => true + | ECon (_, _, SOME e) => passive e + | ENone _ => true + | ESome (_, e) => passive e + | EFfi _ => true + | EAbs _ => true + | ERecord xets => List.all (passive o #2) xets + | EField (e, _) => passive e + | _ => false + + fun exp env e = + let + (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + fun doLet (x, t, e', b) = + let + fun doSub () = + let + val r = subExpInExp (0, e') b + in + (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("r", MonoPrint.p_exp env r)];*) + #1 (reduceExp env r) + end + + fun trySub () = + ((*Print.prefaces "trySub" + [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) + case t of + (TFfi ("Basis", "string"), _) => doSub () + | (TSignal _, _) => e + | _ => + case e' of + (ECase _, _) => e + | _ => doSub ()) + + fun isRecord () = + case #1 e' of + ERecord _ => true + | _ => false + + fun prefixFrom i (e : exp) = + case #1 e of + ERel i' => if i' = i then SOME [] else NONE + | EField (e', s) => + (case prefixFrom i e' of + NONE => NONE + | SOME ss => SOME (ss @ [s])) + | _ => NONE + + fun whichProj i (e : exp) = + case #1 e of + EPrim _ => SOME SLS.empty + | ERel i' => if i' = i then NONE else SOME SLS.empty + | ENamed _ => SOME SLS.empty + | ECon (_, _, NONE) => SOME SLS.empty + | ECon (_, _, SOME e') => whichProj i e' + | ENone _ => SOME SLS.empty + | ESome (_, e') => whichProj i e' + | EFfi _ => SOME SLS.empty + | EFfiApp (_, _, es) => whichProjs i (map #1 es) + | EApp (e1, e2) => whichProjs i [e1, e2] + | EAbs (_, _, _, e) => whichProj (i + 1) e + | EUnop (_, e1) => whichProj i e1 + | EBinop (_, _, e1, e2) => whichProjs i [e1, e2] + | ERecord xets => whichProjs i (map #2 xets) + | EField (e1, s) => + (case prefixFrom i e1 of + NONE => SOME SLS.empty + | SOME ss => SOME (SLS.singleton (ss @ [s]))) + | ECase (e1, pes, _) => + whichProjs' i ((0, e1) + :: map (fn (p, e) => (patBinds p, e)) pes) + | EStrcat (e1, e2) => whichProjs i [e1, e2] + | EError (e1, _) => whichProj i e1 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2] + | ERedirect (e1, _) => whichProj i e1 + | EWrite e1 => whichProj i e1 + | ESeq (e1, e2) => whichProjs i [e1, e2] + | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)] + | EClosure (_, es) => whichProjs i es + | EQuery {query = e1, body = e2, initial = e3, ...} => + whichProjs' i [(0, e1), (2, e2), (0, e3)] + | EDml (e1, _) => whichProj i e1 + | ENextval e1 => whichProj i e1 + | ESetval (e1, e2) => whichProjs i [e1, e2] + | EUnurlify (e1, _, _) => whichProj i e1 + | EJavaScript (_, e1) => whichProj i e1 + | ESignalReturn e1 => whichProj i e1 + | ESignalBind (e1, e2) => whichProjs i [e1, e2] + | ESignalSource e1 => whichProj i e1 + | EServerCall (e1, _, _, _) => whichProj i e1 + | ERecv (e1, _) => whichProj i e1 + | ESleep e1 => whichProj i e1 + | ESpawn e1 => whichProj i e1 + + and whichProjs i es = + whichProjs' i (map (fn e => (0, e)) es) + + and whichProjs' i es = + case es of + [] => SOME SLS.empty + | (n, e) :: es' => + case (whichProj (i + n) e, whichProjs' i es') of + (SOME m1, SOME m2) => + if SLS.isEmpty (SLS.intersection (m1, m2)) then + SOME (SLS.union (m1, m2)) + else + NONE + | _ => NONE + in + if impure env e' then + let + val effs_e' = summarize 0 e' + val effs_e' = List.filter (fn x => x <> UseRel) effs_e' + val effs_b = summarize 0 b + + (*val () = Print.prefaces "Try" + [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*) + ("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("e'_eff", p_events effs_e'), + ("b_eff", p_events effs_b)]*) + + fun does eff = List.exists (fn eff' => eff' = eff) effs_e' + val writesPage = does WritePage + val readsDb = does ReadDb + val writesDb = does WriteDb + val readsCookie = does ReadCookie + val writesCookie = does ReadCookie + + fun verifyUnused eff = + case eff of + UseRel => false + | _ => true + + fun verifyCompatible effs = + case effs of + [] => false + | eff :: effs => + case eff of + Unsure => false + | UseRel => List.all verifyUnused effs + | WritePage => not writesPage andalso verifyCompatible effs + | ReadDb => not writesDb andalso verifyCompatible effs + | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + | ReadCookie => not writesCookie andalso verifyCompatible effs + | WriteCookie => not writesCookie andalso not readsCookie + andalso verifyCompatible effs + | Abort => true + in + (*Print.prefaces "verifyCompatible" + [("e'", MonoPrint.p_exp env e'), + ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), + ("effs_e'", Print.p_list p_event effs_e'), + ("effs_b", Print.p_list p_event effs_b)];*) + if (List.null effs_e' + orelse (List.all (fn eff => eff <> Unsure) effs_e' + andalso verifyCompatible effs_b) + orelse (case effs_b of + UseRel :: effs => List.all verifyUnused effs + | _ => false)) + andalso countFree 0 0 b = 1 + andalso not (freeInAbs b) then + trySub () + else + e + end + else if countFree 0 0 b > 1 + andalso not (!fullMode) + andalso not (passive e') + andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then + e + else + trySub () + end + + val r = + case e of + ERel n => + (case E.lookupERel env n of + (_, _, SOME e') => #1 e' + | _ => e) + | ENamed n => + (case E.lookupENamed env n of + (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), + ("e'", MonoPrint.p_exp env e')];*) + #1 e') + | _ => e) + + | EApp ((EAbs (x, t, _, e1), loc), e2) => + ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), + ("e2", MonoPrint.p_exp env e2), + ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) + if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then + #1 (reduceExp env (ELet (x, t, e2, e1), loc)) + else + #1 (reduceExp env (subExpInExp (0, e2) e1))) + + | ECase (e', pes, {disc, result}) => + let + fun push () = + case result of + (TFun (dom, result), loc) => + let + fun safe e = + List.all (fn UseRel => true + | Abort => true + | _ => false) (summarize 0 e) + + fun p_events' es = Print.box [Print.PD.string "{", + p_events es, + Print.PD.string "}"] + in + if List.all (safe o #2) pes then + (yankedCase := true; + EAbs ("y", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | (p, (EError (e, (TFun (_, t), _)), loc)) => + (p, (EError (liftExpInExp (patBinds p) e, t), loc)) + | (p, e) => + (p, (EApp (liftExpInExp (patBinds p) e, + (ERel (patBinds p), loc)), loc))) + pes, + {disc = disc, result = result}), loc))) + else + e + end + | _ => e + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match ([], p, e') of + No => search pes + | Maybe => push () + | Yes subs => + let + val (body, remaining) = + foldl (fn ((x, t, e), (body, remaining)) => + (if countFree 0 0 body > 1 then + (ELet (x, t, multiLift remaining e, body), #2 e') + else + subExpInExp (0, multiLift remaining e) body, remaining - 1)) + (body, length subs - 1) subs + val r = reduceExp (E.patBinds env p) body + in + (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*) + (*Print.prefaces "ECase" + [("old", MonoPrint.p_exp env body), + ("body", MonoPrint.p_exp env body), + ("r", MonoPrint.p_exp env r)];*) + #1 r + end + in + if impure env e' then + e + else + search pes + end + + | EField (e1, x) => + let + fun yankLets (e : exp) = + case #1 e of + ELet (x, t, e1, e2) => (ELet (x, t, e1, yankLets e2), #2 e) + | ERecord xes => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => e + | NONE => (EField (e, x), #2 e)) + | _ => (EField (e, x), #2 e) + in + #1 (yankLets e1) + end + + | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + let + val e' = (ELet (x2, t2, e1, + (ELet (x1, t1, b1, + liftExpInExp 1 b2), loc)), loc) + in + (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), + ("e'", MonoPrint.p_exp env e')];*) + #1 (reduceExp env e') + end + | EApp ((ELet (x, t, e, b), loc), e') => + #1 (reduceExp env (ELet (x, t, e, + (EApp (b, liftExpInExp 0 e'), loc)), loc)) + + | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + if impure env e' then + doLet (x, t, e', b) + else + EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE) + (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) + + | ELet (x, t, e', b) => doLet (x, t, e', b) + + | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) => + EPrim (Prim.String ((case (k1, k2) of + (Prim.Html, Prim.Html) => Prim.Html + | _ => Prim.Normal), s1 ^ s2)) + + | ESignalBind ((ESignalReturn e1, loc), e2) => + #1 (reduceExp env (EApp (e2, e1), loc)) + + | _ => e + in + (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + r + end + + and bind (env, b) = + case b of + U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs + | U.Decl.RelE (x, t) => E.pushERel env x t NONE + | U.Decl.NamedE (x, n, t, eo, s) => + let + val eo = case eo of + NONE => NONE + | SOME e => if mayInline (n, e, t, s) then + SOME e + else + NONE + in + E.pushENamed env x n t (Option.map (reduceExp env) eo) s + end + + and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env + + fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*) + d) + in + U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file + end + +fun reduce file = + let + val () = yankedCase := false + val file' = reduce' file + in + if !yankedCase then + reduce file' + else + file' + end + + +end diff --git a/src/mono_shake.sig b/src/mono_shake.sig new file mode 100644 index 0000000..813bc52 --- /dev/null +++ b/src/mono_shake.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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. + *) + +(* Remove unused definitions from a file *) + +signature MONO_SHAKE = sig + + val shake : Mono.file -> Mono.file + +end diff --git a/src/mono_shake.sml b/src/mono_shake.sml new file mode 100644 index 0000000..5818fea --- /dev/null +++ b/src/mono_shake.sml @@ -0,0 +1,164 @@ +(* Copyright (c) 2008, 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. + *) + +(* Remove unused definitions from a file *) + +structure MonoShake :> MONO_SHAKE = struct + +open Mono + +structure U = MonoUtil + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +type free = { + con : IS.set, + exp : IS.set +} + +fun shake (file : file) = + let + val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => + (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, (t, e))) + | ((DValRec vis, _), (cdef, edef)) => + (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) + | ((DExport _, _), acc) => acc + | ((DTable _, _), acc) => acc + | ((DSequence _, _), acc) => acc + | ((DView _, _), acc) => acc + | ((DDatabase _, _), acc) => acc + | ((DJavaScript _, _), acc) => acc + | ((DCookie _, _), acc) => acc + | ((DStyle _, _), acc) => acc + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) + (IM.empty, IM.empty) (#1 file) + + fun typ (c, s) = + case c of + TDatatype (n, _) => + if IS.member (#con s, n) then + s + else + let + val s' = {exp = #exp s, + con = IS.add (#con s, n)} + in + case IM.find (cdef, n) of + NONE => s' + | SOME xncs => foldl (fn ((_, _, to), s) => + case to of + NONE => s + | SOME t => shakeTyp s t) + s' xncs + end + | _ => s + + and shakeTyp s = U.Typ.fold typ s + + fun exp (e, s) = + case e of + ENamed n => + if IS.member (#exp s, n) then + s + else + let + val s' = {exp = IS.add (#exp s, n), + con = #con s} + in + case IM.find (edef, n) of + NONE => s' + | SOME (t, e) => shakeExp s' e + end + | _ => s + + and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s + + fun usedVars (cs, es) e = + let + val {con = cs', exp = es'} = shakeExp {con = cs, exp = es} e + in + (cs', es') + end + + val (page_cs, page_es) = + List.foldl + (fn ((DExport (_, _, n, _, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) + | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => + (page_cs, IS.addList (page_es, [n1, n2])) + | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 + | ((DTable (_, xts, e1, e2), _), st) => usedVars (usedVars (usedVars st e1) e2) + (ERecord (map (fn (x, t) => (x, (ERecord [], #2 e1), t)) xts), #2 e1) + | ((DView (_, _, e), _), st) => usedVars st e + | ((DPolicy pol, _), st) => + let + val e1 = case pol of + PolClient e1 => e1 + | PolInsert e1 => e1 + | PolDelete e1 => e1 + | PolUpdate e1 => e1 + | PolSequence e1 => e1 + in + usedVars st e1 + end + | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) + | (_, st) => st) (IS.empty, IS.empty) (#1 file) + + val s = {con = page_cs, exp = page_es} + + val s = IS.foldl (fn (n, s) => + case IM.find (cdef, n) of + NONE => raise Fail "MonoShake: Couldn't find 'datatype'" + | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c + | _ => s) s xncs) s page_cs + + val s = IS.foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "MonoShake: Couldn't find 'val'" + | SOME (t, e) => shakeExp s e) s page_es + in + (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts + | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis + | (DExport _, _) => true + | (DTable _, _) => true + | (DSequence _, _) => true + | (DView _, _) => true + | (DDatabase _, _) => true + | (DJavaScript _, _) => true + | (DCookie _, _) => true + | (DStyle _, _) => true + | (DTask _, _) => true + | (DPolicy _, _) => true + | (DOnError _, _) => true) (#1 file), #2 file) + end + +end diff --git a/src/mono_util.sig b/src/mono_util.sig new file mode 100644 index 0000000..5c078a7 --- /dev/null +++ b/src/mono_util.sig @@ -0,0 +1,161 @@ +(* Copyright (c) 2008, 2013, 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 MONO_UTIL = sig + +structure Typ : sig + val compare : Mono.typ * Mono.typ -> order + val sortFields : (string * Mono.typ) list -> (string * Mono.typ) list + + val mapfold : (Mono.typ', 'state, 'abort) Search.mapfolder + -> (Mono.typ, 'state, 'abort) Search.mapfolder + + val map : (Mono.typ' -> Mono.typ') + -> Mono.typ -> Mono.typ + + val fold : (Mono.typ' * 'state -> 'state) + -> 'state -> Mono.typ -> 'state + + val exists : (Mono.typ' -> bool) -> Mono.typ -> bool +end + +structure Exp : sig + datatype binder = + Datatype of string * int * (string * int * Mono.typ option) list + | RelE of string * Mono.typ + | NamedE of string * int * Mono.typ * Mono.exp option * string + + val mapfoldB : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : ('typtext, Mono.exp', 'state, 'abort) Search.mapfolderB, + bind : 'typtext * binder -> 'typtext} + -> ('typtext, Mono.exp, 'state, 'abort) Search.mapfolderB + val mapfold : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : (Mono.exp', 'state, 'abort) Search.mapfolder} + -> (Mono.exp, 'state, 'abort) Search.mapfolder + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp'} + -> Mono.exp -> Mono.exp + val mapB : {typ : Mono.typ' -> Mono.typ', + exp : 'typtext -> Mono.exp' -> Mono.exp', + bind : 'typtext * binder -> 'typtext} + -> 'typtext -> (Mono.exp -> Mono.exp) + + val fold : {typ : Mono.typ' * 'state -> 'state, + exp : Mono.exp' * 'state -> 'state} + -> 'state -> Mono.exp -> 'state + + val exists : {typ : Mono.typ' -> bool, + exp : Mono.exp' -> bool} -> Mono.exp -> bool + + val existsB : {typ : Mono.typ' -> bool, + exp : 'context * Mono.exp' -> bool, + bind : 'context * binder -> 'context} -> 'context -> Mono.exp -> bool + + val foldB : {typ : Mono.typ' * 'state -> 'state, + exp : 'context * Mono.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.exp -> 'state + + val appLoc : (Mono.exp -> unit) -> Mono.exp -> unit +end + +structure Decl : sig + datatype binder = datatype Exp.binder + + val mapfoldB : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : ('typtext, Mono.exp', 'state, 'abort) Search.mapfolderB, + decl : ('typtext, Mono.decl', 'state, 'abort) Search.mapfolderB, + bind : 'typtext * binder -> 'typtext} + -> ('typtext, Mono.decl, 'state, 'abort) Search.mapfolderB + val mapfold : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : (Mono.exp', 'state, 'abort) Search.mapfolder, + decl : (Mono.decl', 'state, 'abort) Search.mapfolder} + -> (Mono.decl, 'state, 'abort) Search.mapfolder + + val fold : {typ : Mono.typ' * 'state -> 'state, + exp : Mono.exp' * 'state -> 'state, + decl : Mono.decl' * 'state -> 'state} + -> 'state -> Mono.decl -> 'state + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.decl -> Mono.decl + + val foldMap : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : Mono.exp' * 'state -> Mono.exp' * 'state, + decl : Mono.decl' * 'state -> Mono.decl' * 'state} + -> 'state -> Mono.decl -> Mono.decl * 'state + + val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state, + decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state + + val exists : {typ : Mono.typ' -> bool, + exp : Mono.exp' -> bool, + decl : Mono.decl' -> bool} -> Mono.decl -> bool +end + +structure File : sig + datatype binder = datatype Exp.binder + + val mapfoldB : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : ('typtext, Mono.exp', 'state, 'abort) Search.mapfolderB, + decl : ('typtext, Mono.decl', 'state, 'abort) Search.mapfolderB, + bind : 'typtext * binder -> 'typtext} + -> ('typtext, Mono.file, 'state, 'abort) Search.mapfolderB + + val mapfold : {typ : (Mono.typ', 'state, 'abort) Search.mapfolder, + exp : (Mono.exp', 'state, 'abort) Search.mapfolder, + decl : (Mono.decl', 'state, 'abort) Search.mapfolder} + -> (Mono.file, 'state, 'abort) Search.mapfolder + + val mapB : {typ : Mono.typ' -> Mono.typ', + exp : 'typtext -> Mono.exp' -> Mono.exp', + decl : 'typtext -> Mono.decl' -> Mono.decl', + bind : 'typtext * binder -> 'typtext} + -> 'typtext -> Mono.file -> Mono.file + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.file -> Mono.file + + val fold : {typ : Mono.typ' * 'state -> 'state, + exp : Mono.exp' * 'state -> 'state, + decl : Mono.decl' * 'state -> 'state} + -> 'state -> Mono.file -> 'state + + val maxName : Mono.file -> int + + val appLoc : (Mono.exp -> unit) -> Mono.file -> unit +end + +end diff --git a/src/mono_util.sml b/src/mono_util.sml new file mode 100644 index 0000000..fc1a2bc --- /dev/null +++ b/src/mono_util.sml @@ -0,0 +1,825 @@ +(* Copyright (c) 2008, 2013, 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 MonoUtil :> MONO_UTIL = struct + +open Mono + +structure S = Search + +val dummyt = (TRecord [], ErrorMsg.dummySpan) + +structure Typ = struct + +open Order + +fun compare ((t1, _), (t2, _)) = + case (t1, t2) of + (TFun (d1, r1), TFun (d2, r2)) => + join (compare (d1, d2), fn () => compare (r1, r2)) + | (TRecord xts1, TRecord xts2) => + let + val xts1 = sortFields xts1 + val xts2 = sortFields xts2 + in + joinL compareFields (xts1, xts2) + end + | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) + | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) + | (TOption t1, TOption t2) => compare (t1, t2) + | (TList t1, TList t2) => compare (t1, t2) + | (TSource, TSource) => EQUAL + | (TSignal t1, TSignal t2) => compare (t1, t2) + + | (TFun _, _) => LESS + | (_, TFun _) => GREATER + + | (TRecord _, _) => LESS + | (_, TRecord _) => GREATER + + | (TDatatype _, _) => LESS + | (_, TDatatype _) => GREATER + + | (TFfi _, _) => LESS + | (_, TFfi _) => GREATER + + | (TOption _, _) => LESS + | (_, TOption _) => GREATER + + | (TList _, _) => LESS + | (_, TList _) => GREATER + + | (TSource, _) => LESS + | (_, TSource) => GREATER + +and compareFields ((x1, t1), (x2, t2)) = + join (String.compare (x1, x2), + fn () => compare (t1, t2)) + +and sortFields xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts + +fun mapfold fc = + let + fun mft c acc = + S.bindP (mft' c acc, fc) + + and mft' (cAll as (c, loc)) = + case c of + TFun (t1, t2) => + S.bind2 (mft t1, + fn t1' => + S.map2 (mft t2, + fn t2' => + (TFun (t1', t2'), loc))) + | TRecord xts => + S.map2 (ListUtil.mapfold (fn (x, t) => + S.map2 (mft t, + fn t' => + (x, t'))) + xts, + fn xts' => (TRecord xts', loc)) + | TDatatype _ => S.return2 cAll + | TFfi _ => S.return2 cAll + | TOption t => + S.map2 (mft t, + fn t' => + (TOption t, loc)) + | TList t => + S.map2 (mft t, + fn t' => + (TList t, loc)) + | TSource => S.return2 cAll + | TSignal t => + S.map2 (mft t, + fn t' => + (TSignal t, loc)) + in + mft + end + +fun map typ c = + case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of + S.Return () => raise Fail "Mono_util.Typ.map" + | S.Continue (c, ()) => c + +fun fold typ s c = + case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Typ.fold: Impossible" + +fun exists typ k = + case mapfold (fn c => fn () => + if typ c then + S.Return () + else + S.Continue (c, ())) k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure Exp = struct + +datatype binder = + Datatype of string * int * (string * int * typ option) list + | RelE of string * typ + | NamedE of string * int * typ * exp option * string + +fun mapfoldB {typ = fc, exp = fe, bind} = + let + val mft = Typ.mapfold fc + + fun mfe ctx e acc = + S.bindP (mfe' ctx e acc, fe ctx) + + and mfet ctx (e, t) = + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => (e', t'))) + + and mfe' ctx (eAll as (e, loc)) = + case e of + EPrim _ => S.return2 eAll + | ERel _ => S.return2 eAll + | ENamed _ => S.return2 eAll + | ECon (_, _, NONE) => S.return2 eAll + | ECon (dk, n, SOME e) => + S.map2 (mfe ctx e, + fn e' => + (ECon (dk, n, SOME e'), loc)) + | ENone t => + S.map2 (mft t, + fn t' => + (ENone t', loc)) + | ESome (t, e) => + S.bind2 (mft t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (ESome (t', e'), loc))) + | EFfi _ => S.return2 eAll + | EFfiApp (m, x, es) => + S.map2 (ListUtil.mapfold (fn e => mfet ctx e) es, + fn es' => + (EFfiApp (m, x, es'), loc)) + | 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 (mft dom, + fn dom' => + S.bind2 (mft ran, + fn ran' => + S.map2 (mfe (bind (ctx, RelE (x, dom'))) e, + fn e' => + (EAbs (x, dom', ran', e'), loc)))) + + | EUnop (s, e) => + S.map2 (mfe ctx e, + fn e' => + (EUnop (s, e'), loc)) + | EBinop (bi, s, e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EBinop (bi, s, e1', e2'), loc))) + + | ERecord xes => + S.map2 (ListUtil.mapfold (fn (x, e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (x, e', t')))) + xes, + fn xes' => + (ERecord xes', loc)) + | EField (e, x) => + S.map2 (mfe ctx e, + fn e' => + (EField (e', x), 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 + | PNone _ => ctx + | PSome (_, p) => pb (p, ctx) + in + S.map2 (mfe (pb (p, ctx)) e, + fn e' => (p, e')) + end) pes, + fn pes' => + S.bind2 (mft disc, + fn disc' => + S.map2 (mft result, + fn result' => + (ECase (e', pes', {disc = disc', result = result'}), loc))))) + + | EError (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (EError (e', t'), loc))) + | EReturnBlob {blob = NONE, mimeType, t} => + S.bind2 (mfe ctx mimeType, + fn mimeType' => + S.map2 (mft t, + fn t' => + (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc))) + | EReturnBlob {blob = SOME blob, mimeType, t} => + S.bind2 (mfe ctx blob, + fn blob' => + S.bind2 (mfe ctx mimeType, + fn mimeType' => + S.map2 (mft t, + fn t' => + (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc)))) + | ERedirect (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (ERedirect (e', t'), loc))) + + | EStrcat (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (EStrcat (e1', e2'), loc))) + + | EWrite e => + S.map2 (mfe ctx e, + fn e' => + (EWrite e', loc)) + + | ESeq (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESeq (e1', e2'), loc))) + | ELet (x, t, e1, e2) => + S.bind2 (mft t, + fn t' => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, + fn e2' => + (ELet (x, t', e1', e2'), loc)))) + + | EClosure (n, es) => + S.map2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + (EClosure (n, es'), loc)) + + | EQuery {exps, tables, state, query, body, initial} => + S.bind2 (ListUtil.mapfold (fn (x, t) => + S.map2 (mft t, + fn t' => (x, t'))) exps, + fn exps' => + S.bind2 (ListUtil.mapfold (fn (x, xts) => + S.map2 (ListUtil.mapfold + (fn (x, t) => + S.map2 (mft t, + fn t' => (x, t'))) xts, + fn xts' => (x, xts'))) tables, + fn tables' => + S.bind2 (mft state, + fn state' => + S.bind2 (mfe ctx query, + fn query' => + S.bind2 (mfe (bind (bind (ctx, RelE ("r", dummyt)), + RelE ("acc", dummyt))) + body, + fn body' => + (* ASK: is this the right thing to do? *) + S.map2 (mfe ctx initial, + fn initial' => + (EQuery {exps = exps', + tables = tables', + state = state', + query = query', + body = body', + initial = initial'}, + loc))))))) + + | EDml (e, fm) => + S.map2 (mfe ctx e, + fn e' => + (EDml (e', fm), loc)) + | ENextval e => + S.map2 (mfe ctx e, + fn e' => + (ENextval e', loc)) + | ESetval (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESetval (e1', e2'), loc))) + | EUnurlify (e, t, b) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (EUnurlify (e', t', b), loc))) + | EJavaScript (m, e) => + S.bind2 (mfmode ctx m, + fn m' => + S.map2 (mfe ctx e, + fn e' => + (EJavaScript (m', e'), loc))) + + | ESignalReturn e => + S.map2 (mfe ctx e, + fn e' => + (ESignalReturn e', loc)) + | ESignalBind (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESignalBind (e1', e2'), loc))) + | ESignalSource e => + S.map2 (mfe ctx e, + fn e' => + (ESignalSource e', loc)) + + | EServerCall (s, t, eff, fm) => + S.bind2 (mfe ctx s, + fn s' => + S.map2 (mft t, + fn t' => + (EServerCall (s', t', eff, fm), loc))) + | ERecv (s, t) => + S.bind2 (mfe ctx s, + fn s' => + S.map2 (mft t, + fn t' => + (ERecv (s', t'), loc))) + | ESleep s => + S.map2 (mfe ctx s, + fn s' => + (ESleep s', loc)) + + | ESpawn s => + S.map2 (mfe ctx s, + fn s' => + (ESpawn s', loc)) + + and mfmode ctx mode = + case mode of + Attribute => S.return2 mode + | Script => S.return2 mode + | Source t => + S.map2 (mft t, + fn t' => Source t') + in + mfe + end + +fun mapfold {typ = fc, exp = fe} = + mapfoldB {typ = fc, + exp = fn () => fe, + bind = fn ((), _) => ()} () + +fun mapB {typ, exp, bind} ctx e = + case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()), + bind = bind} ctx e () of + S.Continue (e, ()) => e + | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible" + +fun map {typ, exp} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ())} e () of + S.Return () => raise Fail "Mono_util.Exp.map" + | S.Continue (e, ()) => e + +fun fold {typ, exp} s e = + case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), + exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible" + +fun exists {typ, exp} k = + case mapfold {typ = fn c => fn () => + if typ c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ())} k () of + S.Return _ => true + | S.Continue _ => false + +fun existsB {typ, exp, bind} ctx e = + case mapfoldB {typ = fn t => fn () => + if typ t then + S.Return () + else + S.Continue (t, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx e () of + S.Return _ => true + | S.Continue _ => false + +fun foldB {typ, exp, bind} ctx s e = + case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" + +fun appLoc f = + let + fun appl e = + (f e; + case #1 e of + EPrim _ => () + | ERel _ => () + | ENamed _ => () + | ECon (_, _, eo) => Option.app appl eo + | ENone _ => () + | ESome (_, e) => appl e + | EFfi _ => () + | EFfiApp (_, _, es) => app (appl o #1) es + | EApp (e1, e2) => (appl e1; appl e2) + | EAbs (_, _, _, e1) => appl e1 + | EUnop (_, e1) => appl e1 + | EBinop (_, _, e1, e2) => (appl e1; appl e2) + | ERecord xets => app (appl o #2) xets + | EField (e1, _) => appl e1 + | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes) + | EStrcat (e1, e2) => (appl e1; appl e2) + | EError (e1, _) => appl e1 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2) + | ERedirect (e1, _) => appl e1 + | EWrite e1 => appl e1 + | ESeq (e1, e2) => (appl e1; appl e2) + | ELet (_, _, e1, e2) => (appl e1; appl e2) + | EClosure (_, es) => app appl es + | EQuery {query = e1, body = e2, initial = e3, ...} => (appl e1; appl e2; appl e3) + | EDml (e1, _) => appl e1 + | ENextval e1 => appl e1 + | ESetval (e1, e2) => (appl e1; appl e2) + | EUnurlify (e1, _, _) => appl e1 + | EJavaScript (_, e1) => appl e1 + | ESignalReturn e1 => appl e1 + | ESignalBind (e1, e2) => (appl e1; appl e2) + | ESignalSource e1 => appl e1 + | EServerCall (e1, _, _, _) => appl e1 + | ERecv (e1, _) => appl e1 + | ESleep e1 => appl e1 + | ESpawn e1 => appl e1) + in + appl + end + +end + +structure Decl = struct + +datatype binder = datatype Exp.binder + +fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = + let + val mft = Typ.mapfold fc + + val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind} + + fun mfd ctx d acc = + S.bindP (mfd' ctx d acc, fd ctx) + + and mfd' ctx (dAll as (d, loc)) = + case d of + DDatatype dts => + S.map2 (ListUtil.mapfold (fn (x, n, xncs) => + S.map2 (ListUtil.mapfold (fn (x, n, c) => + case c of + NONE => S.return2 (x, n, c) + | SOME c => + S.map2 (mft c, + fn c' => (x, n, SOME c'))) xncs, + fn xncs' => (x, n, xncs'))) dts, + fn dts' => + (DDatatype dts', loc)) + | DVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (DVal vi', loc)) + | DValRec vis => + let + val ctx' = foldl (fn ((x, n, t, _, s), ctx') => bind (ctx', NamedE (x, n, t, NONE, s))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx') vis, + fn vis' => + (DValRec vis', loc)) + end + | DExport (ek, s, n, ts, t, b) => + S.bind2 (ListUtil.mapfold mft ts, + fn ts' => + S.map2 (mft t, + fn t' => + (DExport (ek, s, n, ts', t', b), loc))) + | DTable (s, xts, pe, ce) => + S.bind2 (mfe ctx pe, + fn pe' => + S.map2 (mfe ctx ce, + fn ce' => + (DTable (s, xts, pe', ce'), loc))) + | DSequence _ => S.return2 dAll + | DView (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DView (s, xts, e'), loc)) + | DDatabase _ => S.return2 dAll + | DJavaScript _ => S.return2 dAll + | DCookie _ => S.return2 dAll + | 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 pol => + S.map2 (mfpol ctx pol, + fn p' => + (DPolicy p', loc)) + | DOnError _ => S.return2 dAll + + and mfpol ctx pol = + case pol of + PolClient e => + S.map2 (mfe ctx e, + PolClient) + | PolInsert e => + S.map2 (mfe ctx e, + PolInsert) + | PolDelete e => + S.map2 (mfe ctx e, + PolDelete) + | PolUpdate e => + S.map2 (mfe ctx e, + PolUpdate) + | PolSequence e => + S.map2 (mfe ctx e, + PolSequence) + + and mfvi ctx (x, n, t, e, s) = + S.bind2 (mft t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (x, n, t', e', s))) + in + mfd + end + +fun mapfold {typ = fc, exp = fe, decl = fd} = + mapfoldB {typ = fc, + exp = fn () => fe, + decl = fn () => fd, + bind = fn ((), _) => ()} () + +fun fold {typ, exp, decl} s d = + case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), + exp = fn e => fn s => S.Continue (e, exp (e, s)), + decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible" + +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" + | S.Continue (e, ()) => e + +fun foldMap {typ, exp, decl} s d = + case mapfold {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s)), + decl = fn d => fn s => S.Continue (decl (d, s))} d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMap: Impossible" + +fun foldMapB {typ, exp, decl, bind} ctx s d = + case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" + +fun exists {typ, exp, decl} k = + case mapfold {typ = fn c => fn () => + if typ c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ()), + decl = fn d => fn () => + if decl d then + S.Return () + else + S.Continue (d, ())} k () of + S.Return _ => true + | S.Continue _ => false + +end + +structure File = struct + +datatype binder = datatype Exp.binder + +fun mapfoldB (all as {bind, ...}) = + let + val mfd = Decl.mapfoldB all + + fun mff ctx (ds, ps) = + case ds of + nil => S.return2 (nil, ps) + | d :: ds' => + S.bind2 (mfd ctx d, + fn d' => + let + val ctx' = + case #1 d' of + DDatatype dts => + foldl (fn ((x, n, xncs), ctx) => + let + val ctx = bind (ctx, Datatype (x, n, xncs)) + val t = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), + #2 d') + in + foldl (fn ((x, n, to), ctx) => + let + val t = case to of + NONE => t + | SOME t' => (TFun (t', t), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, "")) + end) + ctx xncs + end) ctx dts + | DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s)) + | DValRec vis => foldl (fn ((x, n, t, e, s), ctx) => + bind (ctx, NamedE (x, n, t, NONE, s))) ctx vis + | DExport _ => ctx + | DTable _ => ctx + | DSequence _ => ctx + | DView _ => ctx + | DDatabase _ => ctx + | DJavaScript _ => ctx + | DCookie _ => ctx + | DStyle _ => ctx + | DTask _ => ctx + | DPolicy _ => ctx + | DOnError _ => ctx + in + S.map2 (mff ctx' (ds', ps), + fn (ds', _) => + (d' :: ds', ps)) + end) + in + mff + end + +fun mapfold {typ = fc, exp = fe, decl = fd} = + mapfoldB {typ = fc, + exp = fn () => fe, + decl = fn () => fd, + bind = fn ((), _) => ()} () + +fun mapB {typ, exp, decl, bind} ctx ds = + case mapfoldB {typ = fn c => fn () => S.Continue (typ 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 ds () of + S.Continue (ds, ()) => ds + | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible" + +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "MonoUtil.File.map: Impossible" + | S.Continue (e, ()) => e + +fun fold {typ, exp, decl} s d = + case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)), + exp = fn e => fn s => S.Continue (e, exp (e, s)), + decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" + +fun maxName (f : file) = + foldl (fn ((d, _) : decl, count) => + case d of + DDatatype dts => + foldl (fn ((_, n, ns), count) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns) count dts + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DView _ => count + | DDatabase _ => count + | DJavaScript _ => count + | DCookie _ => count + | DStyle _ => count + | DTask _ => count + | DPolicy _ => count + | DOnError _ => count) 0 (#1 f) + +fun appLoc f (fl : file) = + let + val eal = Exp.appLoc f + + fun appl (d : decl) = + case #1 d of + DDatatype _ => () + | DVal (_, _, _, e1, _) => eal e1 + | DValRec vis => app (eal o #4) vis + | DExport _ => () + | DTable (_, _, e1, e2) => (eal e1; eal e2) + | DSequence _ => () + | DView (_, _, e1) => eal e1 + | DDatabase _ => () + | DJavaScript _ => () + | DCookie _ => () + | DStyle _ => () + | DTask (e1, e2) => (eal e1; eal e2) + | DPolicy pol => applPolicy pol + | DOnError _ => () + + and applPolicy p = + case p of + PolClient e1 => eal e1 + | PolInsert e1 => eal e1 + | PolDelete e1 => eal e1 + | PolUpdate e1 => eal e1 + | PolSequence e1 => eal e1 + in + app appl (#1 fl) + end + +end + +end diff --git a/src/monoize.sig b/src/monoize.sig new file mode 100644 index 0000000..951db01 --- /dev/null +++ b/src/monoize.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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 MONOIZE = sig + + val monoize : CoreEnv.env -> Core.file -> Mono.file + + val liftExpInExp : int -> Mono.exp -> Mono.exp + +end diff --git a/src/monoize.sml b/src/monoize.sml new file mode 100644 index 0000000..ddf6cd4 --- /dev/null +++ b/src/monoize.sml @@ -0,0 +1,4549 @@ +(* Copyright (c) 2008-2014, 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 Monoize :> MONOIZE = struct + +structure E = ErrorMsg +structure Env = CoreEnv + +structure L = Core +structure L' = Mono + +structure IM = IntBinaryMap +structure IS = IntBinarySet + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) + +structure RM = BinaryMapFn(struct + type ord_key = (string * L'.typ) list + fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan), + (L'.TRecord r2, E.dummySpan)) + end) + +val nextPvar = MonoFooify.nextPvar +val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) +val pvarDefs = MonoFooify.pvarDefs +val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) + +fun choosePvar () = + let + val n = !nextPvar + in + nextPvar := n + 1; + n + end + +fun pvar (r, r', loc) = + case RM.find (!pvars, r') of + NONE => + let + val n = choosePvar () + val fs = map (fn (x, t) => (x, choosePvar (), t)) r' + val r = ListMergeSort.sort (fn (((L.CName x, _), _), ((L.CName y, _), _)) => String.compare (x, y) = GREATER + | _ => raise Fail "Monoize: pvar, not CName") r + val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) => + ((x, n, SOME t) :: r, + SM.insert (fs', x, n))) ([], SM.empty) (r, fs) + in + pvars := RM.insert (!pvars, r', (n, fs)); + pvarDefs := ("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs) + :: !pvarDefs; + pvarOldDefs := (n, r) :: !pvarOldDefs; + (n, fs) + end + | SOME v => v + +val singletons = SS.addList (SS.empty, + ["link", + "br", + "p", + "hr", + "input", + "img", + "base", + "meta", + "param", + "area", + "col"]) + +val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) + +structure U = MonoUtil + +val liftExpInExp = + U.Exp.mapB {typ = fn t => t, + exp = fn bound => fn e => + case e of + L'.ERel xn => + if xn < bound then + e + else + L'.ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +fun monoName env (all as (c, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported name constructor"; + Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; + "") + in + case c of + L.CName s => s + | _ => poly () + end + +fun lowercaseFirst "" = "" + | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) + ^ String.extract (s, 1, NONE) + +fun monoNameLc env c = lowercaseFirst (monoName env c) + +fun readType' (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), + (L'.TOption t, loc)), loc) +fun readErrType (t, loc) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), + t), loc) +fun readType (t, loc) = + (L'.TRecord [("Read", readType' (t, loc)), + ("ReadError", readErrType (t, loc))], + loc) + +fun monoType env = + let + fun mt env dtmap (all as (c, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported type constructor"; + Print.eprefaces' [("Constructor", CorePrint.p_con env all)]; + dummyTyp) + in + case c of + L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc) + | L.TCFun _ => poly () + | L.TRecord (L.CRecord ((L.KType, _), xcs), _) => + let + val xcs = map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs + val xcs = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xcs + in + (L'.TRecord xcs, loc) + end + | L.TRecord _ => poly () + + | L.CApp ((L.CFfi ("Basis", "option"), _), t) => + (L'.TOption (mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "list"), _), t) => + (L'.TList (mt env dtmap t), loc) + + | L.CApp ((L.CFfi ("Basis", "variant"), _), (L.CRecord ((L.KType, _), xts), _)) => + let + val xts' = map (fn (x, t) => (monoName env x, mt env dtmap t)) xts + val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' + val (n, cs) = pvar (xts, xts', loc) + val cs = map (fn (x, n, t) => (x, n, SOME t)) cs + in + (L'.TDatatype (n, ref (ElabUtil.classifyDatatype cs, cs)), loc) + end + + | L.CApp ((L.CFfi ("Basis", "monad"), _), _) => + (L'.TRecord [], loc) + + | L.CApp ((L.CFfi ("Basis", "eq"), _), t) => + let + val t = mt env dtmap t + in + (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc) + end + | L.CApp ((L.CFfi ("Basis", "num"), _), t) => + let + val t = mt env dtmap t + in + (L'.TRecord [("Zero", t), + ("Neg", (L'.TFun (t, t), loc)), + ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Pow", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], + loc) + end + | L.CApp ((L.CFfi ("Basis", "ord"), _), t) => + let + val t = mt env dtmap t + in + (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)), + ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], + loc) + end + | L.CApp ((L.CFfi ("Basis", "show"), _), t) => + (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) + | L.CApp ((L.CFfi ("Basis", "read"), _), t) => + readType (mt env dtmap t, loc) + + | L.CFfi ("Basis", "unit") => (L'.TRecord [], loc) + | L.CFfi ("Basis", "page") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xhead") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xbody") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xtable") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xtr") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "xform") => (L'.TFfi ("Basis", "string"), loc) + + | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "mimeType") => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_value") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "meta") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "data_attr_kind") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc) + + | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) => + (L'.TFfi ("Basis", "string"), loc) + + | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => + (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "source"), _), t) => + (L'.TSource, loc) + | L.CApp ((L.CFfi ("Basis", "signal"), _), t) => + (L'.TSignal (mt env dtmap t), loc) + | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_view"), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "sql_sequence") => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query1"), _), _), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_expw"), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_window"), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => + (L'.TFfi ("Basis", "sql_constraints"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "linkable"), _), _), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) => + let + val string = (L'.TFfi ("Basis", "string"), loc) + in + (L'.TRecord [("1", string), ("2", string)], loc) + end + | L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "dml") => + (L'.TFfi ("Basis", "string"), loc) + + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => + (L'.TRecord [], loc) + | L.CFfi ("Basis", "sql_relop") => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "sql_direction") => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_order_by"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "sql_limit") => + (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "sql_offset") => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "fieldsOf"), _), _), _), _) => + (L'.TRecord [], loc) + + | L.CApp ((L.CFfi ("Basis", "sql_injectable_prim"), _), t) => + (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) + | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) => + (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_aggregate"), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_summable"), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) => + (L'.TRecord [], loc) + | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) => + (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_partition"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) + + | L.CApp ((L.CFfi ("Basis", "channel"), _), _) => + (L'.TFfi ("Basis", "channel"), loc) + + | L.CRel _ => poly () + | L.CNamed n => + (case IM.find (dtmap, n) of + SOME r => (L'.TDatatype (n, r), loc) + | NONE => + let + val r = ref (L'.Default, []) + val (_, xs, xncs) = Env.lookupDatatype env n + + val dtmap' = IM.insert (dtmap, n, r) + + val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs + in + case xs of + [] =>(r := (ElabUtil.classifyDatatype xncs, xncs); + (L'.TDatatype (n, r), loc)) + | _ => poly () + end) + | L.CFfi mx => (L'.TFfi mx, loc) + | L.CApp _ => poly () + | L.CAbs _ => poly () + + | L.CName _ => poly () + + | L.CRecord _ => poly () + | L.CConcat _ => poly () + | L.CMap _ => poly () + | L.CUnit => poly () + + | L.CTuple _ => poly () + | L.CProj _ => poly () + + | L.CKAbs _ => poly () + | L.CKApp _ => poly () + | L.TKFun _ => poly () + end + in + mt env IM.empty + end + +val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) + +structure Fm = MonoFooify.Fm + +fun fooifyExp fk env = + MonoFooify.fooifyExp + fk + (fn n => + let + val (_, t, _, s) = Env.lookupENamed env n + in + (monoType env t, s) + end) + (fn n => + let + val (x, _, xncs) = Env.lookupDatatype env n + in + (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) + end) + +val attrifyExp = fooifyExp MonoFooify.Attr +val urlifyExp = fooifyExp MonoFooify.Url + +datatype 'a failable_search = + Found of 'a + | NotFound + | Error + +structure St :> sig + type t + + val empty : t + + val radioGroup : t -> string option + val setRadioGroup : t * string -> t +end = struct + +type t = { + radioGroup : string option +} + +val empty = {radioGroup = NONE} + +fun radioGroup (t : t) = #radioGroup t + +fun setRadioGroup (t : t, x) = {radioGroup = SOME x} + +end + +fun monoPatCon env pc = + case pc of + L.PConVar n => L'.PConVar n + | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con, + arg = Option.map (monoType env) arg} + +val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan) + + +fun listify t = (L'.TRecord [("1", t), ("2", (L'.TList t, #2 t))], #2 t) + +fun monoPat env (all as (p, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported pattern"; + Print.eprefaces' [("Pattern", CorePrint.p_pat env all)]; + dummyPat) + in + case p of + L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) + | L.PPrim p => (L'.PPrim p, loc) + | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc) + | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) => + (L'.PNone (listify (monoType env t)), loc) + | L.PCon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME p) => + (L'.PSome (listify (monoType env t), monoPat env p), loc) + | L.PCon (L.Option, _, [t], NONE) => (L'.PNone (monoType env t), loc) + | L.PCon (L.Option, pc, [t], SOME p) => (L'.PSome (monoType env t, monoPat env p), loc) + | L.PCon _ => poly () + | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) + end + +fun strcat loc es = + case es of + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) + | [e] => e + | _ => + let + val e2 = List.last es + val es = List.take (es, length es - 1) + val e1 = List.last es + val es = List.take (es, length es - 1) + in + foldr (fn (e, e') => (L'.EStrcat (e, e'), loc)) + (L'.EStrcat (e1, e2), loc) es + end + +fun strcatComma loc es = + case es of + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) + | [e] => e + | _ => + let + val e1 = List.last es + val es = List.take (es, length es - 1) + in + foldr (fn (e, e') => + case (e, e') of + ((L'.EPrim (Prim.String (_, "")), _), _) => e' + | (_, (L'.EPrim (Prim.String (_, "")), _)) => e + | _ => + (L'.EStrcat (e, + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, ", ")), loc), e'), loc)), loc)) + e1 es + end + +fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs) + +val readCookie = ref IS.empty + +fun isBlobby (t : L.con) = + case #1 t of + L.CFfi ("Basis", "string") => true + | L.CFfi ("Basis", "blob") => true + | _ => false + +fun monoExp (env, st, fm) (all as (e, loc)) = + let + val strcat = strcat loc + val strcatComma = strcatComma loc + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) + + fun poly () = + (E.errorAt loc "Unsupported expression"; + Print.eprefaces' [("Expression", CorePrint.p_exp env all)]; + (dummyExp, fm)) + + fun numTy t = + (L'.TRecord [("Zero", t), + ("Neg", (L'.TFun (t, t), loc)), + ("Plus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Minus", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Times", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Div", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Mod", (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Pow", (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc) + fun numEx (t, zero, neg, plus, minus, times, dv, md, ex) = + ((L'.ERecord [("Zero", (L'.EPrim zero, loc), t), + ("Neg", neg, (L'.TFun (t, t), loc)), + ("Plus", plus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Minus", minus, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Times", times, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Div", dv, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Mod", md, (L'.TFun (t, (L'.TFun (t, t), loc)), loc)), + ("Pow", ex, (L'.TFun (t, (L'.TFun (t, t), loc)), loc))], loc), fm) + + fun ordTy t = + (L'.TRecord [("Lt", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)), + ("Le", (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], loc) + fun ordEx (t, lt, le) = + ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)), + ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))], + loc), fm) + + fun outerRec xts = + (L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) => + (x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc)) + | (x, all as (_, loc)) => + (E.errorAt loc "Unsupported record field constructor"; + Print.eprefaces' [("Name", CorePrint.p_con env x), + ("Constructor", CorePrint.p_con env all)]; + ("", dummyTyp))) xts), loc) + in + case e of + L.EPrim p => ((L'.EPrim p, loc), fm) + | L.ERel n => ((L'.ERel n, loc), fm) + | L.ENamed n => ((L'.ENamed n, loc), fm) + | L.ECon (dk, pc, [], eo) => + let + val (eo, fm) = + case eo of + NONE => (NONE, fm) + | SOME e => + let + val (e, fm) = monoExp (env, st, fm) e + in + (SOME e, fm) + end + in + ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) + end + | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], NONE) => + ((L'.ENone (listify (monoType env t)), loc), fm) + | L.ECon (L.Option, L.PConFfi {mod = "Basis", datatyp = "list", ...}, [t], SOME e) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.ESome (listify (monoType env t), e), loc), fm) + end + | L.ECon (L.Option, _, [t], NONE) => + ((L'.ENone (monoType env t), loc), fm) + | L.ECon (L.Option, _, [t], SOME e) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.ESome (monoType env t, e), loc), fm) + end + | L.ECon _ => poly () + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "make"), _), nmC as (L.CName nm, _)), _), + t), _), + (L.CRecord (_, xts), _)) => + let + val t' = monoType env t + val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts + val xts' = (nm, t') :: xts' + val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' + val (n, cs) = pvar ((nmC, t) :: xts, xts', loc) + val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs + val cl = ElabUtil.classifyDatatype cs' + in + case List.find (fn (nm', _, _) => nm' = nm) cs of + NONE => raise Fail "Monoize: Polymorphic variant tag mismatch for 'make'" + | SOME (_, n', _) => ((L'.EAbs ("x", t', (L'.TDatatype (n, ref (cl, cs')), loc), + (L'.ECon (cl, L'.PConVar n', SOME (L'.ERel 0, loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "match"), _), (L.CRecord (_, xts), _)), _), + t) => + let + val t = monoType env t + val xts' = map (fn (x, t) => (monoName env x, monoType env t)) xts + val xts' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts' + val (n, cs) = pvar (xts, xts', loc) + val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs + val cl = ElabUtil.classifyDatatype cs' + val fs = (L'.TRecord (map (fn (x, t') => (x, (L'.TFun (t', t), loc))) xts'), loc) + val dt = (L'.TDatatype (n, ref (cl, cs')), loc) + in + ((L'.EAbs ("v", + dt, + (L'.TFun (fs, t), loc), + (L'.EAbs ("fs", fs, t, + (L'.ECase ((L'.ERel 1, loc), + map (fn (x, n', t') => + ((L'.PCon (cl, L'.PConVar n', SOME (L'.PVar ("x", t'), loc)), loc), + (L'.EApp ((L'.EField ((L'.ERel 1, loc), x), loc), + (L'.ERel 0, loc)), loc))) cs, + {disc = dt, result = t}), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "eq"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "ne"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.EAbs ("x", t, (L'.TFun (t, b), loc), + (L'.EAbs ("y", t, b, + (L'.EUnop ("!", (L'.EApp ((L'.EApp ((L'.ERel 2, loc), + (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc)), loc)), + loc)), + loc)), + loc), fm) + end + | L.EFfi ("Basis", "eq_int") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), + (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.Int, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.EFfi ("Basis", "eq_float") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), + (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.EFfi ("Basis", "eq_bool") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), + (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.EFfi ("Basis", "eq_string") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), + (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, "!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.EFfi ("Basis", "eq_char") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), + (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + | L.EFfi ("Basis", "eq_time") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), + (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), + ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc), + fm) + + | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = (L'.TFun (t, (L'.TFun (t, b), loc)), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end + + | L.ECApp ((L.EFfi ("Basis", "zero"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, t, + (L'.EField ((L'.ERel 0, loc), "Zero"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "neg"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, t), loc), + (L'.EField ((L'.ERel 0, loc), "Neg"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "plus"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Plus"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "minus"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Minus"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "times"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Times"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "divide"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Div"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "mod"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Mod"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "pow"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", numTy t, (L'.TFun (t, (L'.TFun (t, t), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Pow"), loc)), loc), fm) + end + | L.EFfi ("Basis", "num_int") => + let + fun intBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), + (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), + (L'.TFfi ("Basis", "int"), loc), + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + numEx ((L'.TFfi ("Basis", "int"), loc), + Prim.Int (Int64.fromInt 0), + (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), + (L'.TFfi ("Basis", "int"), loc), + (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), + intBin "+", + intBin "-", + intBin "*", + intBin "/", + intBin "%", + intBin "powl" + ) + end + | L.EFfi ("Basis", "num_float") => + let + fun floatBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), + (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), + (L'.TFfi ("Basis", "float"), loc), + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + numEx ((L'.TFfi ("Basis", "float"), loc), + Prim.Float 0.0, + (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), + (L'.TFfi ("Basis", "float"), loc), + (L'.EUnop ("-", (L'.ERel 0, loc)), loc)), loc), + floatBin "+", + floatBin "-", + floatBin "*", + floatBin "fdiv", + floatBin "fmod", + floatBin "powf" + ) + end + + | L.ECApp ((L.EFfi ("Basis", "lt"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Lt"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "le"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("r", ordTy t, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc), + (L'.EField ((L'.ERel 0, loc), "Le"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "gt"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + in + ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc), + (L'.EAbs ("x", t, (L'.TFun (t, b), loc), + (L'.EAbs ("y", t, b, + (L'.EUnop ("!", + (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc), + "Le"), loc), + (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc)), loc)), loc)), + loc)), + loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "ge"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + in + ((L'.EAbs ("f", ordTy t, (L'.TFun (t, (L'.TFun (t, b), loc)), loc), + (L'.EAbs ("x", t, (L'.TFun (t, b), loc), + (L'.EAbs ("y", t, b, + (L'.EUnop ("!", + (L'.EApp ((L'.EApp ((L'.EField ((L'.ERel 2, loc), + "Lt"), loc), + (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc)), loc)), loc)), + loc)), + loc), fm) + end + | L.EFfi ("Basis", "ord_int") => + let + fun intBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), + (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "int"), loc), + intBin "<", + intBin "<=") + end + | L.EFfi ("Basis", "ord_float") => + let + fun floatBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), + (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "float"), loc), + floatBin "<", + floatBin "<=") + end + | L.EFfi ("Basis", "ord_bool") => + let + fun boolBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), + (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "bool"), loc), + boolBin "<", + boolBin "<=") + end + | L.EFfi ("Basis", "ord_string") => + let + fun boolBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), + (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, s, + (L'.EBinop (L'.NotInt, "strcmp", + (L'.ERel 1, loc), + (L'.ERel 0, loc)), loc), + (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "string"), loc), + boolBin "<", + boolBin "<=") + end + | L.EFfi ("Basis", "ord_char") => + let + fun charBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), + (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "char"), loc), + charBin "<", + charBin "<=") + end + | L.EFfi ("Basis", "ord_time") => + let + fun boolBin s = + (L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), + (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), + (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), + (L'.TFfi ("Basis", "bool"), loc), + (L'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), + ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc) + in + ordEx ((L'.TFfi ("Basis", "time"), loc), + boolBin "lt_time", + boolBin "le_time") + end + | L.ECApp ((L.EFfi ("Basis", "mkOrd"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = ordTy t + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end + + | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc), + (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_int") => + ((L'.EFfi ("Basis", "intToString"), loc), fm) + | L.EFfi ("Basis", "show_float") => + ((L'.EFfi ("Basis", "floatToString"), loc), fm) + | L.EFfi ("Basis", "show_string") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_queryString") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_url") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_css_class") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_id") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.EFfi ("Basis", "show_char") => + ((L'.EFfi ("Basis", "charToString"), loc), fm) + | L.EFfi ("Basis", "show_bool") => + ((L'.EFfi ("Basis", "boolToString"), loc), fm) + | L.EFfi ("Basis", "show_time") => + ((L'.EFfi ("Basis", "timeToString"), loc), fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_xml"), _), _),_), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "show_sql_query"), _), _), _), _), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "mkShow"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "string"), loc) + val dom = (L'.TFun (t, b), loc) + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end + + | L.ECApp ((L.EFfi ("Basis", "read"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", readType (t, loc), readType' (t, loc), + (L'.EField ((L'.ERel 0, loc), "Read"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "readError"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", readType (t, loc), readErrType (t, loc), + (L'.EField ((L'.ERel 0, loc), "ReadError"), loc)), loc), fm) + end + | L.ECApp ((L.EFfi ("Basis", "mkRead"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "string"), loc) + val b' = (L'.TOption b, loc) + val dom = (L'.TFun (t, b), loc) + val dom' = (L'.TFun (t, b'), loc) + in + ((L'.EAbs ("f", dom, (L'.TFun (dom', readType (t, loc)), loc), + (L'.EAbs ("f'", dom', readType (t, loc), + (L'.ERecord [("Read", (L'.ERel 0, loc), dom), + ("ReadError", (L'.ERel 1, loc), dom')], loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "read_int") => + let + val t = (L'.TFfi ("Basis", "int"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToInt"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToInt_error"), loc), readErrType (t, loc))], + loc), + fm) + end + | L.EFfi ("Basis", "read_float") => + let + val t = (L'.TFfi ("Basis", "float"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToFloat"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToFloat_error"), loc), readErrType (t, loc))], + loc), + fm) + end + | L.EFfi ("Basis", "read_string") => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.ERecord [("Read", (L'.EAbs ("s", s, (L'.TOption s, loc), + (L'.ESome (s, (L'.ERel 0, loc)), loc)), loc), readType' (s, loc)), + ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc), + fm) + end + | L.EFfi ("Basis", "read_char") => + let + val t = (L'.TFfi ("Basis", "char"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))], + loc), + fm) + end + | L.EFfi ("Basis", "read_bool") => + let + val t = (L'.TFfi ("Basis", "bool"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToBool"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToBool_error"), loc), readErrType (t, loc))], + loc), + fm) + end + | L.EFfi ("Basis", "read_time") => + let + val t = (L'.TFfi ("Basis", "time"), loc) + in + ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToTime"), loc), readType' (t, loc)), + ("ReadError", (L'.EFfi ("Basis", "stringToTime_error"), loc), readErrType (t, loc))], + loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "transaction_return"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, + (L'.TFun ((L'.TRecord [], loc), t), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), t, + (L'.ERel 1, loc)), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "transaction_bind"), _), t1), _), t2) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TFun (un, t1), loc) + val mt2 = (L'.TFun (un, t2), loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc), + (L'.ERecord [], loc)), loc), + (L'.EApp ( + (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc), + (L'.ERecord [], loc)), + loc)), loc)), loc)), loc)), loc), + fm) + end + + | L.EApp ((L.ECApp ((L.EFfi ("Basis", "recv"), _), t1), _), ch) => + let + val un = (L'.TRecord [], loc) + val t1 = monoType env t1 + val (ch, fm) = monoExp (env, st, fm) ch + in + ((L'.EAbs ("_", un, un, (L'.ERecv (liftExpInExp 0 ch, t1), loc)), loc), fm) + end + | L.EFfiApp ("Basis", "recv", _) => poly () + + | L.EFfiApp ("Basis", "float", [(e, t)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm) + end + + | L.EFfiApp ("Basis", "sleep", [(n, _)]) => + let + val (n, fm) = monoExp (env, st, fm) n + in + ((L'.ESleep n, loc), fm) + end + | L.EFfiApp ("Basis", "sleep", _) => poly () + + | L.ECApp ((L.EFfi ("Basis", "source"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), + (L'.EFfiApp ("Basis", "new_client_source", + [((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc), + (L'.TSource, loc))]), + loc)), loc)), + loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "set"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TSource, loc), + (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), + (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.EFfiApp ("Basis", "set_client_source", + [((L'.ERel 2, loc), (L'.TSource, loc)), + ((L'.EJavaScript (L'.Source t, + (L'.ERel 1, loc)), loc), + (L'.TFfi ("Basis", "string"), loc))]), + loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "get"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TSource, loc), + (L'.TFun ((L'.TRecord [], loc), t), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), t, + (L'.EFfiApp ("Basis", "get_client_source", + [((L'.ERel 1, loc), (L'.TSource, loc))]), + loc)), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "current"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("src", (L'.TSource, loc), + (L'.TFun ((L'.TRecord [], loc), t), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), t, + (L'.EFfiApp ("Basis", "current", + [((L'.ERel 1, loc), (L'.TSource, loc))]), + loc)), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "spawn", [(e, _)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.ESpawn e, loc), fm) + end + + | L.ECApp ((L.EFfi ("Basis", "signal_return"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", t, (L'.TSignal t, loc), + (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "signal_bind"), _), t1), _), t2) => + let + val t1 = monoType env t1 + val t2 = monoType env t2 + val un = (L'.TRecord [], loc) + val mt1 = (L'.TSignal t1, loc) + val mt2 = (L'.TSignal t2, loc) + in + ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc), + (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2, + (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc), + (L'.ESignalSource (L'.ERel 0, loc), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + in + ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), + (L'.EAbs ("_", un, s, + (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [((L'.ERel 1, loc), s)]), loc), + t, true), + loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "setCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + val t = monoType env t + val rt = (L'.TRecord [("Value", t), + ("Expires", (L'.TOption (L'.TFfi ("Basis", "time"), + loc), loc)), + ("Secure", (L'.TFfi ("Basis", "bool"), loc))], loc) + + fun fd x = (L'.EField ((L'.ERel 1, loc), x), loc) + val (e, fm) = urlifyExp env fm (fd "Value", t) + in + ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), + (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.EFfiApp ("Basis", "set_cookie", [(str (Settings.getUrlPrefix ()), s), + ((L'.ERel 2, loc), s), + (e, s), + (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), + (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))]) + , loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "clearCookie"), _), t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + in + ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.EFfiApp ("Basis", "clear_cookie", + [(str (Settings.getUrlPrefix ()), s), + ((L'.ERel 1, loc), s)]), + loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc), + (L'.EFfiApp ("Basis", "new_channel", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "send"), _), t) => + let + val t = monoType env t + val (e, fm) = urlifyExp env fm ((L'.ERel 1, loc), t) + in + ((L'.EAbs ("ch", (L'.TFfi ("Basis", "channel"), loc), + (L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc), + (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.EFfiApp ("Basis", "send", + [((L'.ERel 2, loc), (L'.TFfi ("Basis", "channel"), loc)), + (e, (L'.TFfi ("Basis", "string"), loc))]), + loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => + (str "", fm) + | L.ECApp ( + (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), + nm), _), + (L.CRecord (_, unique), _)) => + let + val unique = (nm, t) :: unique + val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) + in + ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), + (str + (String.concatWith ", " + (map (fn (x, _) => + Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique)))), + loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => + ((L'.ERecord [], loc), + fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) => + ((L'.EAbs ("c", + (L'.TFfi ("Basis", "string"), loc), + (L'.TFfi ("Basis", "sql_constraints"), loc), + (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc), + fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join_constraints"), _), + _), _), + _), _), + _) => + let + val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc) + in + ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc), + (L'.EAbs ("cs2", constraints, constraints, + (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _), + nm), _), + (L.CRecord (_, unique), _)) => + let + val unique = (nm, t) :: unique + in + (str ("UNIQUE (" + ^ String.concatWith ", " + (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique) + ^ ")"), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "linkable_same"), loc), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "linkable_from_nullable"), loc), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "linkable_to_nullable"), loc), _) => + ((L'.ERecord [], loc), fm) + + | L.EFfi ("Basis", "mat_nil") => + let + val string = (L'.TFfi ("Basis", "string"), loc) + val stringE = str "" + in + ((L'.ERecord [("1", stringE, string), + ("2", stringE, string)], loc), fm) + end + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "mat_cons"), _), + _), _), + _), _), + _), _), + _), _), + (L.CName nm1, _)), _), + (L.CName nm2, _)) => + let + val string = (L'.TFfi ("Basis", "string"), loc) + val mat = (L'.TRecord [("1", string), ("2", string)], loc) + in + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), + (L'.EAbs ("m", mat, mat, + (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)), + string), + ("2", str (Settings.mangleSql (lowercaseFirst nm2)), + string)], loc)), + ((L'.PVar ("_", string), loc), + (L'.ERecord [("1", (L'.EStrcat ( + str (Settings.mangleSql (lowercaseFirst nm1) + ^ ", "), + (L'.EField ((L'.ERel 1, loc), "1"), loc)), + loc), string), + ("2", (L'.EStrcat ( + str (Settings.mangleSql (lowercaseFirst nm2) + ^ ", "), + (L'.EField ((L'.ERel 1, loc), "2"), loc)), + loc), string)], + loc))], + {disc = string, + result = mat}), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm) + | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm) + | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm) + | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "foreign_key"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val unit = (L'.TRecord [], loc) + val string = (L'.TFfi ("Basis", "string"), loc) + val mat = (L'.TRecord [("1", string), ("2", string)], loc) + val recd = (L'.TRecord [("OnDelete", string), + ("OnUpdate", string)], loc) + + fun strcat [] = raise Fail "Monoize.strcat" + | strcat [e] = e + | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc) + + fun prop (fd, kw) = + (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), + str ""), + ((L'.PVar ("_", string), loc), + strcat [str (" ON " ^ kw ^ " "), + (L'.EField ((L'.ERel 1, loc), fd), loc)])], + {disc = string, + result = string}), loc) + in + ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc), + (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc), + (L'.EAbs ("pr", recd, string, + strcat [str "FOREIGN KEY (", + (L'.EField ((L'.ERel 2, loc), "1"), loc), + str ") REFERENCES ", + (L'.ERel 1, loc), + str " (", + (L'.EField ((L'.ERel 2, loc), "2"), loc), + str ")", + prop ("OnDelete", "DELETE"), + prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_exp_weaken"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val string = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("e", string, string, (L'.ERel 0, loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "check"), _), _) => + let + val string = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("e", string, string, + (L'.EStrcat (str "CHECK ", + (L'.EFfiApp ("Basis", "checkString", + [((L'.ERel 0, loc), string)]), loc)), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "dml", [(e, _)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EDml (e, L'.Error), loc), + fm) + end + + | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EDml (e, L'.None), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) => + (case monoType env (L.TRecord fields, loc) of + (L'.TRecord fields, _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val fields = map (fn (x, _) => (x, s)) fields + val rt = (L'.TRecord fields, loc) + in + ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), + (L'.EAbs ("fs", rt, s, + strcat [str "INSERT INTO ", + (L'.ERel 1, loc), + str " (", + strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields), + str ") VALUES (", + strcatComma (map (fn (x, _) => + (L'.EField ((L'.ERel 0, loc), + x), loc)) fields), + str ")"]), loc)), loc), + fm) + end + | _ => poly ()) + + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) => + (case monoType env (L.TRecord changed, loc) of + (L'.TRecord changed, _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val changed = map (fn (x, _) => (x, s)) changed + val rt = (L'.TRecord changed, 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, + if #supportsUpdateAs (Settings.currentDbms ()) then + strcat [str "UPDATE ", + (L'.ERel 1, loc), + str " AS T_T SET ", + strcatComma (map (fn (x, _) => + strcat [str (Settings.mangleSql x + ^ " = "), + (L'.EField + ((L'.ERel 2, + loc), + x), loc)]) + changed), + str " WHERE ", + (L'.ERel 0, loc)] + else + strcat [str "UPDATE ", + (L'.ERel 1, loc), + str " SET ", + strcatComma (map (fn (x, _) => + strcat [str (Settings.mangleSql x + ^ " = "), + (L'.EFfiApp ("Basis", "unAs", + [((L'.EField + ((L'.ERel 2, + loc), + x), loc), + s)]), loc)]) + changed), + str " WHERE ", + (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), + loc)), loc)), loc), + fm) + end + | _ => poly ()) + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e", s, s, + if #supportsDeleteAs (Settings.currentDbms ()) then + strcat [str "DELETE FROM ", + (L'.ERel 1, loc), + str " AS T_T WHERE ", + (L'.ERel 0, loc)] + else + strcat [str "DELETE FROM ", + (L'.ERel 1, loc), + str " WHERE ", + (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "query"), _), (L.CRecord (_, tables), _)), _), + exps), _), + state) => + (case monoType env (L.TRecord exps, loc) of + (L'.TRecord exps, _) => + let + val tables = map (fn ((L.CName x, _), xts) => + (case monoType env (L.TRecord xts, loc) of + (L'.TRecord xts, _) => SOME (x, xts) + | _ => NONE) + | _ => NONE) tables + in + if List.exists (fn x => x = NONE) tables then + poly () + else + let + val tables = List.mapPartial (fn x => x) tables + val state = monoType env state + val s = (L'.TFfi ("Basis", "string"), loc) + val un = (L'.TRecord [], loc) + + val rt = exps @ map (fn (x, xts) => (x, (L'.TRecord xts, loc))) tables + val ft = (L'.TFun ((L'.TRecord rt, loc), + (L'.TFun (state, + (L'.TFun (un, state), loc)), + loc)), loc) + + val body' = (L'.EApp ( + (L'.EApp ( + (L'.EApp ((L'.ERel 4, loc), + (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc), + (L'.ERecord [], loc)), loc) + val body = (L'.EQuery {exps = exps, + tables = tables, + state = state, + query = (L'.ERel 3, loc), + body = body', + initial = (L'.ERel 1, loc)}, + loc) + in + ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), + (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc), + (L'.EAbs ("i", state, (L'.TFun (un, state), loc), + (L'.EAbs ("_", un, state, + body), loc)), loc)), loc)), loc), fm) + end + end + | _ => poly ()) + + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) + in + ((L'.EAbs ("r", + (L'.TRecord [("Rows", s), ("OrderBy", s), ("Limit", s), ("Offset", s)], loc), + s, + strcat [gf "Rows", + (L'.ECase (gf "OrderBy", + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), + ((L'.PVar ("orderby", s), loc), + strcat [str " ORDER BY ", + (L'.ERel 0, loc)])], + {disc = s, result = s}), loc), + gf "Limit", + gf "Offset"]), loc), fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_query1"), _), + _), _), + _), _), + (L.CRecord (_, tables), _)), _), + (L.CRecord (_, grouped), _)), _), + (L.CRecord (_, stables), _)), _), + sexps), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val b = (L'.TFfi ("Basis", "bool"), loc) + val un = (L'.TRecord [], loc) + fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) + + fun doTables tables = + let + val tables = map (fn ((L.CName x, _), xts) => + (case monoType env (L.TRecord xts, loc) of + (L'.TRecord xts, _) => SOME (x, xts) + | _ => NONE) + | _ => NONE) tables + in + if List.exists (fn x => x = NONE) tables then + NONE + else + let + val tables = List.mapPartial (fn x => x) tables + val tables = ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) + tables + val tables = map (fn (x, xts) => + (x, ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) + xts)) tables + in + SOME tables + end + end + in + case (doTables tables, doTables grouped, doTables stables, monoType env (L.TRecord sexps, loc)) of + (SOME tables, SOME grouped, SOME stables, (L'.TRecord sexps, _)) => + let + val sexps = ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps + in + ((L'.EAbs ("r", + (L'.TRecord [("Distinct", b), + ("From", s), + ("Where", s), + ("GroupBy", un), + ("Having", s), + ("SelectFields", un), + ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], + loc), + s, + strcat [str "SELECT ", + (L'.ECase (gf "Distinct", + [((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + str "DISTINCT "), + ((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + str "")], + {disc = b, result = s}), loc), + strcatComma (map (fn (x, t) => + strcat [ + (L'.EField (gf "SelectExps", x), loc), + str (" AS " ^ Settings.mangleSql x) + ]) sexps + @ map (fn (x, xts) => + strcatComma + (map (fn (x', _) => + str ("T_" ^ x + ^ "." + ^ Settings.mangleSql x')) + xts)) stables), + (L'.ECase (gf "From", + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), + ((L'.PVar ("x", s), loc), + strcat [str " FROM ", + (L'.ERel 0, loc)])], + {disc = s, + result = s}), loc), + (L'.ECase (gf "Where", + [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), + loc), + str ""), + ((L'.PVar ("where", s), loc), + strcat [str " WHERE ", (L'.ERel 0, loc)])], + {disc = s, + result = s}), loc), + + if List.all (fn (x, xts) => + case List.find (fn (x', _) => x' = x) grouped of + NONE => List.null xts + | SOME (_, xts') => + List.all (fn (x, _) => + List.exists (fn (x', _) => x' = x) + xts') xts) tables then + str "" + else + strcat [ + str " GROUP BY ", + strcatComma (map (fn (x, xts) => + strcatComma + (map (fn (x', _) => + str ("T_" ^ x + ^ "." + ^ Settings.mangleSql x')) + xts)) grouped) + ], + + (L'.ECase (gf "Having", + [((L'.PPrim (Prim.String + (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), + str ""), + ((L'.PVar ("having", s), loc), + strcat [str " HAVING ", (L'.ERel 0, loc)])], + {disc = s, + result = s}), loc) + ]), loc), + fm) + end + | _ => poly () + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_inject"), _), + _), _), + _), _), + _), _), + t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", (L'.TFun (t, s), loc), (L'.TFun (t, s), loc), + (L'.ERel 0, loc)), loc), fm) + end + + | L.EFfi ("Basis", "sql_int") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyInt", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "int"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_float") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyFloat", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "float"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_bool") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBool", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "bool"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_string") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_char") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_time") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyTime", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_blob") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBlob", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "blob"), loc))]), loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyChannel", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "channel"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_client") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_url") => + ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) => + let + val t = monoType env t + val tf = (L'.TFun (t, (L'.TFfi ("Basis", "string"), loc)), loc) + in + ((L'.EAbs ("f", tf, tf, (L'.ERel 0, loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "sql_option_prim"), _), t) => + let + val t = monoType env t + val s = (L'.TFfi ("Basis", "string"), loc) + + fun toSqlType (t : L'.typ) = + case #1 t of + L'.TFfi ("Basis", "int") => Settings.Int + | L'.TFfi ("Basis", "float") => Settings.Float + | L'.TFfi ("Basis", "string") => Settings.String + | L'.TFfi ("Basis", "char") => Settings.Char + | L'.TFfi ("Basis", "bool") => Settings.Bool + | L'.TFfi ("Basis", "time") => Settings.Time + | L'.TFfi ("Basis", "blob") => Settings.Blob + | L'.TFfi ("Basis", "channel") => Settings.Channel + | L'.TFfi ("Basis", "client") => Settings.Client + | _ => raise Fail "Monoize/sql_option_prim: invalid SQL type" + in + ((L'.EAbs ("f", + (L'.TFun (t, s), loc), + (L'.TFun ((L'.TOption t, loc), s), loc), + (L'.EAbs ("x", + (L'.TOption t, loc), + s, + (L'.ECase ((L'.ERel 0, loc), + [((L'.PNone t, loc), + str (#p_cast (Settings.currentDbms ()) ("NULL", toSqlType t))), + ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), + (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], + {disc = (L'.TOption t, loc), + result = s}), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.ERecord [], loc)), loc), + fm) + + | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"), + _), _), _), _), _), _), _), _) => + let + val un = (L'.TRecord [], loc) + in + ((L'.EAbs ("_", un, (L'.TFun (un, un), loc), + (L'.EAbs ("_", un, un, + (L'.ERecord [], loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "fieldsOf_table"), _), _), _), _) => + ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "fieldsOf_view"), _), _) => + ((L'.ERecord [], loc), fm) + + | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) => + (str "", fm) + | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), + _), _), _), _), _), _), _), + (L.CName name, _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("tab", s, s, + strcat [(L'.ERel 0, loc), + str (" AS T_" ^ name)]), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _), + _), _), _), + (L.CName name, _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("q", s, s, + strcat [str "(", + (L'.ERel 0, loc), + str (") AS T_" ^ name)]), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) + in + ((L'.EAbs ("tab1", s, (L'.TFun (s, s), loc), + (L'.EAbs ("tab2", s, s, + (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s), + ("2", (L'.ERel 0, loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), + (L'.ERel 0, loc)), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), + (L'.ERel 1, loc)), + ((L'.PVar ("_", disc), loc), + strcat [(L'.ERel 2, loc), + str ", ", + (L'.ERel 1, loc)])], + {disc = disc, + result = s}), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) + in + ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), + (L'.EAbs ("on", s, s, + (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), + ("2", (L'.ERel 1, loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), + (L'.ERel 1, loc)), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), + (L'.ERel 2, loc)), + ((L'.PVar ("_", disc), loc), + strcat ((if #nestedRelops + (Settings.currentDbms ()) then + [str "("] + else + []) + @ [(L'.ERel 3, loc), + str " JOIN ", + (L'.ERel 2, loc), + str " ON ", + (L'.ERel 1, loc)] + @ (if #nestedRelops + (Settings.currentDbms ()) then + [str ")"] + else + [])))], + {disc = disc, + result = s}), loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), _), _), + (L.CRecord (_, right), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) + in + ((L'.EAbs ("_", outerRec right, + (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), + (L'.EAbs ("on", s, s, + (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), + ("2", (L'.ERel 1, loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 1, loc)), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 2, loc)), + ((L'.PVar ("_", disc), loc), + strcat ((if #nestedRelops + (Settings.currentDbms ()) then + [str "("] + else + []) + @ [(L'.ERel 3, loc), + str " LEFT JOIN ", + (L'.ERel 2, loc), + str " ON ", + (L'.ERel 1, loc)] + @ (if #nestedRelops + (Settings.currentDbms ()) then + [str ")"] + else + [])))], + {disc = disc, + result = s}), loc)), loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)), + _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) + in + ((L'.EAbs ("_", outerRec left, + (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), + (L'.EAbs ("on", s, s, + (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), + ("2", (L'.ERel 1, loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 1, loc)), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 2, loc)), + ((L'.PVar ("_", disc), loc), + strcat ((if #nestedRelops + (Settings.currentDbms ()) then + [str "("] + else + []) + @ [(L'.ERel 3, loc), + str " RIGHT JOIN ", + (L'.ERel 2, loc), + str " ON ", + (L'.ERel 1, loc)] + @ (if #nestedRelops + (Settings.currentDbms ()) then + [str ")"] + else + [])))], + {disc = disc, + result = s}), loc)), loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _), + (L.CRecord (_, right), _)), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TRecord [("1", s), ("2", s)], loc) + in + ((L'.EAbs ("_", outerRec (left @ right), + (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc), + (L'.EAbs ("on", s, s, + (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), + ("2", (L'.ERel 1, loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 1, loc)), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), + loc), s)], loc), + (L'.ERel 2, loc)), + ((L'.PVar ("_", disc), loc), + strcat ((if #nestedRelops + (Settings.currentDbms ()) then + [str "("] + else + []) + @ [(L'.ERel 3, loc), + str " FULL JOIN ", + (L'.ERel 2, loc), + str " ON ", + (L'.ERel 1, loc)] + @ (if #nestedRelops + (Settings.currentDbms ()) then + [str ")"] + else + [])))], + {disc = disc, + result = s}), loc)), loc)), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => + (str "", fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => + (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_order_by_Cons"), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("d", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e2", s, s, + (L'.ECase ((L'.ERel 0, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strcat [(L'.ERel 2, loc), + (L'.ERel 1, loc)]), + ((L'.PVar ("_", s), loc), + strcat [(L'.ERel 3, loc), + (L'.ERel 2, loc), + str ", ", + (L'.ERel 1, loc)])], + {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), + fm) + end + + | L.EFfi ("Basis", "sql_no_limit") => + (str "", fm) + | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + (strcat [ + str " LIMIT ", + (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) + ], + fm) + end + + | L.EFfi ("Basis", "sql_no_offset") => + (str "", fm) + | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + (strcat [ + str " OFFSET ", + (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) + ], + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => + (str "=", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => + (str "<>", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => + (str "<", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => + (str "<=", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => + (str ">", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => + (str ">=", fm) + + | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "+"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "-"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "*"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "/"), loc), fm) + | L.EFfi ("Basis", "sql_mod") => + (str "%", fm) + + | L.EFfi ("Basis", "sql_like") => + (str "LIKE", fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_unary"), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), + strcat [str "(", + (L'.ERel 1, loc), + str " ", + (L'.ERel 0, loc), + str ")"]), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_not") => (str "NOT", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "-"), loc), fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_binary"), _), + _), _), + _), _), + _), _), + arg1), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + + fun default n = strcat [str "(", + (L'.ERel (n + 1), loc), + str " ", + (L'.ERel (n + 2), loc), + str " ", + (L'.ERel n, loc), + str ")"] + + val body = case #1 arg1 of + L.CApp ((L.CFfi ("Basis", "option"), _), _) => + (L'.ECase ((L'.ERel 2, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc), + if #supportsIsDistinctFrom (Settings.currentDbms ()) then + strcat [str "((", + (L'.ERel 1, loc), + str " IS NOT DISTINCT FROM ", + (L'.ERel 0, loc), + str "))"] + else + strcat [str "((", + (L'.ERel 1, loc), + str " ", + (L'.ERel 2, loc), + str " ", + (L'.ERel 0, loc), + str ") OR ((", + (L'.ERel 1, loc), + str ") IS NULL AND (", + (L'.ERel 0, loc), + str ") IS NULL))"]), + ((L'.PVar ("_", s), loc), + default 1)], + {disc = s, + result = s}), loc) + | _ => default 0 + in + ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e2", s, s, + body), loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_and") => (str "AND", fm) + | L.EFfi ("Basis", "sql_or") => (str "OR", fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_field"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + (L.CName tab, _)), _), + (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_exp"), _), + _), _), + _), _), + _), _), + _), _), + (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_relop"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + val disc = (L'.TFfi ("Basis", "bool"), loc) + in + (if #nestedRelops (Settings.currentDbms ()) then + (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e2", s, s, + strcat [str "((", + (L'.ERel 1, loc), + str ") ", + (L'.ERel 3, loc), + (L'.ECase ((L'.ERel 2, loc), + [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, NONE), loc), + str " ALL"), + ((L'.PVar ("_", disc), loc), + str "")], + {disc = disc, + result = s}), loc), + str " (", + (L'.ERel 0, loc), + str "))"]), loc)), loc)), loc)), loc) + else + (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), + (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), + (L'.EAbs ("e2", s, s, + strcat [(L'.ERel 1, loc), + str " ", + (L'.ERel 3, loc), + (L'.ECase ((L'.ERel 2, loc), + [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, NONE), loc), + str " ALL"), + ((L'.PVar ("_", disc), loc), + str "")], + {disc = disc, + result = s}), loc), + str " ", + (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_forget_tables"), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), + fm) + end + + | L.EFfi ("Basis", "sql_union") => (str "UNION", fm) + | L.EFfi ("Basis", "sql_intersect") => + (if #onlyUnion (Settings.currentDbms ()) then + ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT." + else + (); + (str "INTERSECT", fm)) + | L.EFfi ("Basis", "sql_except") => + (if #onlyUnion (Settings.currentDbms ()) then + ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT." + else + (); + (str "EXCEPT", fm)) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_count"), _), + _), _), + _), _), + _) => (str "COUNT(*)", fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_aggregate"), _), + _), _), + _), _), + _), _), + _), _), + t) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + + val main = strcat [(L'.ERel 1, loc), + str "(", + (L'.ERel 0, loc), + str ")"] + in + ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) => + (str "COUNT", fm) + + | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_summable_option"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.ERecord [], loc)), loc), + fm) + | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "AVG"), loc), + fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "SUM"), loc)), loc), + fm) + + | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_arith_float") => ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_arith_option"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.ERecord [], loc)), loc), + fm) + + | L.EFfi ("Basis", "sql_maxable_int") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_maxable_float") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_maxable_string") => ((L'.ERecord [], loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_maxable_option"), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.ERecord [], loc)), loc), + fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "MAX"), loc)), loc), + fm) + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), + (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), + str "MIN"), loc)), loc), + fm) + + | L.EFfi ("Basis", "sql_asc") => (str "", fm) + | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_nfunc"), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), + fm) + end + + | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm) + | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_window"), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), + (L'.EAbs ("e", s, s, + (L'.ERel 0, loc)), loc)), loc), + fm) + end + + | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm) + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_ufunc"), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x", s, s, + strcat [(L'.ERel 1, loc), + str "(", + (L'.ERel 0, loc), + str ")"]), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_octet_length") => + (str (if #supportsOctetLength (Settings.currentDbms ()) then + "octet_length" + else + "length"), fm) + | L.EFfi ("Basis", "sql_lower") => + (str "lower", fm) + | L.EFfi ("Basis", "sql_upper") => + (str "upper", fm) + | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => + ((L'.EFfi ("Basis", "sql_known"), loc), fm) + + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_is_null"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("s", s, s, + strcat [str "(", + (L'.ERel 0, loc), + str " IS NULL)"]), loc), + fm) + end + + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_coalesce"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x1", s, s, + strcat [str "COALESCE(", + (L'.ERel 1, loc), + str ",", + (L'.ERel 0, loc), + str ")"]), loc)), loc), + fm) + end + + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_if_then_else"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("then", s, (L'.TFun (s, s), loc), + (L'.EAbs ("else", s, s, + strcat [str "(CASE WHEN (", + (L'.ERel 2, loc), + str ") THEN (", + (L'.ERel 1, loc), + str ") ELSE (", + (L'.ERel 0, loc), + str ") END)"]), loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_nullable"), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc), + (L'.EAbs ("x", s, s, + (L'.ERel 0, loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_subquery"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), + (L'.EAbs ("x", s, s, + strcat [str "(", + (L'.ERel 0, loc), + str ")"]), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_no_partition"), _), + _), _), + _), _), + _) => (str "", fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_partition"), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_window_function"), _), + _), _), + _), _), + _), _), + _) => + let + val () = if #windowFunctions (Settings.currentDbms ()) then + () + else + ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions." + + val s = (L'.TFfi ("Basis", "string"), loc) + + val main = strcat [(L'.ERel 2, loc), + str " OVER (", + (L'.ERel 1, loc), + (L'.ECase ((L'.ERel 0, loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), + ((L'.PVar ("_", s), loc), + strcat [str " ORDER BY ", + (L'.ERel 1, loc)])], + {disc = s, + result = s}), loc), + str ")"] + in + ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("p", s, (L'.TFun (s, s), loc), + (L'.EAbs ("o", s, s, + main), loc)), loc)), loc), + fm) + end + + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_window_aggregate"), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + + val main = strcat [(L'.ERel 1, loc), + str "(", + (L'.ERel 0, loc), + str ")"] + in + ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), + (L'.EAbs ("e1", s, s, main), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) => + (str "COUNT(*)", fm) + | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) => + (str "RANK()", fm) + + | L.EFfiApp ("Basis", "nextval", [(e, _)]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.ENextval e, loc), fm) + end + | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) => + let + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (env, st, fm) e2 + in + ((L'.ESetval (e1, e2), loc), fm) + end + + | L.EFfi ("Basis", "null") => (str "", fm) + + | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), + fm) + end + + | L.EFfi ("Basis", "data_kind") => (str "data-", fm) + | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm) + + | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) => + let + val (sk, fm) = monoExp (env, st, fm) sk + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (sk, + (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), + (L'.EStrcat (str "=\"", + (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), + str "\""), loc)), + loc)), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "css_url", [(s, _)]) => + let + val (s, fm) = monoExp (env, st, fm) s + in + ((L'.EStrcat (str "url(", + (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), + str ")"), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "property", [(s, _)]) => + let + val (s, fm) = monoExp (env, st, fm) s + in + ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), + str ":"), loc), + fm) + end + | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), + fm) + end + + | L.EFfi ("Basis", "noStyle") => (str "", fm) + | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc), + fm) + end + + | L.EApp ( + (L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), + _), _), + se) => + let + val (se, fm) = monoExp (env, st, fm) se + in + ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm) + end + | L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _), + _) => + ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm) + + | L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join"), + _), _), _), + _), _), + _), _), + _), _), + xml1), _), + xml2) => + let + val (xml1, fm) = monoExp (env, st, fm) xml1 + val (xml2, fm) = monoExp (env, st, fm) xml2 + in + ((L'.EStrcat (xml1, xml2), loc), fm) + end + + | L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _), + class), _), + dynClass), _), + style), _), + dynStyle), _), + attrs), _), + tag), _), + xml) => + let + fun getTag' (e, _) = + case e of + L.EFfi (_, tag) => (tag, []) + | L.ECApp (e, t) => let + val (tag, ts) = getTag' e + in + (tag, ts @ [t]) + end + | _ => (E.errorAt loc "Non-constant XML tag"; + Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; + ("", [])) + + fun getTag (e, _) = + case e of + L.EFfiApp (_, tag, [((L.ERecord [], _), _)]) => (tag, []) + | L.EApp (e, (L.ERecord [], _)) => getTag' e + | _ => (E.errorAt loc "Non-constant XML tag"; + Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; + ("", [])) + + val (tag, targs) = getTag tag + + val (attrs, fm) = monoExp (env, st, fm) attrs + val attrs = case #1 attrs of + L'.ERecord xes => xes + | _ => map (fn ((L.CName x, _), t) => (x, (L'.EField (attrs, x), loc), monoType env t) + | (c, t) => (E.errorAt loc "Non-constant field name for HTML tag attribute"; + Print.eprefaces' [("Name", CorePrint.p_con env c)]; + ("", (L'.EField (attrs, ""), loc), monoType env t))) attrsGiven + + val attrs = + if List.exists (fn ("Link", _, _) => true + | _ => false) attrs then + List.filter (fn ("Href", _, _) => false + | _ => true) attrs + else + attrs + + fun findOnload (attrs, onload, onunload, acc) = + case attrs of + [] => (onload, onunload, acc) + | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc) + | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc) + | x :: rest => findOnload (rest, onload, onunload, x :: acc) + + val (onload, onunload, attrs) = + if tag = "body" then + findOnload (attrs, NONE, NONE, []) + else + (NONE, NONE, attrs) + + val (class, fm) = monoExp (env, st, fm) class + val (dynClass, fm) = monoExp (env, st, fm) dynClass + val (style, fm) = monoExp (env, st, fm) style + val (dynStyle, fm) = monoExp (env, st, fm) dynStyle + + (* Special case for <button value=""> *) + val (attrs, extraString) = case tag of + "button" => + (case List.partition (fn (x, _, _) => x = "Value") attrs of + ([(_, value, _)], rest) => + (rest, SOME value) + | _ => (attrs, NONE)) + | "body" => + (attrs, + if (case (#1 dynClass, #1 dynStyle) of + (L'.ESome _, _) => true + | (_, L'.ESome _) => true + | _ => false) then + let + fun jsify (e : L'.exp) = + case #1 e of + L'.ESome (_, ds) => strcat [str "execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str ")"] + | _ => str "null" + in + SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(", + jsify dynClass, + str ",", + jsify dynStyle, + str ")</script>"]) + end + else + NONE) + | _ => (attrs, NONE) + + + val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] + + fun isSome (e, _) = + case e of + L'.ESome _ => true + | _ => false + + val () = if isSome dynClass orelse isSome dynStyle then + if List.exists (fn x => x = tag) dynamics then + E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional <span> may be useful") + else + () + else + () + + fun tagStart tag' = + let + val t = (L'.TFfi ("Basis", "string"), loc) + val s = strH (String.concat ["<", tag']) + + val s = (L'.EStrcat (s, + (L'.ECase (class, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), + ((L'.PVar ("x", t), loc), + (L'.EStrcat (strH " class=\"", + (L'.EStrcat ((L'.ERel 0, loc), + strH "\""), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) + + val s = (L'.EStrcat (s, + (L'.ECase (style, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), + ((L'.PVar ("x", t), loc), + (L'.EStrcat (strH " style=\"", + (L'.EStrcat ((L'.ERel 0, loc), + strH "\""), + loc)), loc))], + {disc = t, + result = t}), loc)), loc) + + val (s, fm) = foldl (fn (("Action", _, _), acc) => acc + | (("Source", _, _), acc) => acc + | (("Data", e, _), (s, fm)) => + ((L'.EStrcat (s, + (L'.EStrcat ( + strH " ", + e), loc)), loc), + fm) + | ((x, e, t), (s, fm)) => + case t of + (L'.TFfi ("Basis", "bool"), _) => + let + val s' = " " ^ lowercaseFirst x + in + ((L'.ECase (e, + [((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + (L'.EStrcat (s, + strH s'), loc)), + ((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + s)], + {disc = (L'.TFfi ("Basis", "bool"), loc), + result = (L'.TFfi ("Basis", "string"), loc)}), loc), + fm) + end + | (L'.TFun (dom, _), _) => + let + val e = + case #1 dom of + L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc) + | _ => + if String.isPrefix "Onkey" x then + (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "keyEvent", []), loc)), + loc), (L'.ERecord [], loc)), loc) + else + (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "mouseEvent", []), loc)), + loc), (L'.ERecord [], loc)), loc) + + val s' = " " ^ lowercaseFirst x ^ "='uw_event=event;exec(" + in + ((L'.EStrcat (s, + (L'.EStrcat ( + strH s', + (L'.EStrcat ( + (L'.EJavaScript (L'.Attribute, e), loc), + strH ")'"), loc)), + loc)), loc), + fm) + end + | _ => + let + val fooify = + case x of + "Link" => urlifyExp + | "Action" => urlifyExp + | _ => attrifyExp + + val x = + case x of + "Typ" => "Type" + | "Nam" => "Name" + | "Link" => "Href" + | _ => x + + val x = String.translate (fn #"_" => "-" + | ch => String.str ch) x + + val xp = " " ^ lowercaseFirst x ^ "=\"" + + val (e, fm) = fooify env fm (e, t) + val e = case (tag, x) of + ("coption", "Value") => (L'.EStrcat (strH "x", e), loc) + | _ => e + in + ((L'.EStrcat (s, + (L'.EStrcat (strH xp, + (L'.EStrcat (e, + strH "\""), + loc)), + loc)), loc), + fm) + end) + (s, fm) attrs + in + (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then + (L'.EStrcat (s, + strH " value=\"\""), loc) + else + s, + fm) + end + + fun input typ = + case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to input tag") + + fun normal (tag, extra) = + let + val (tagStart, fm) = tagStart tag + val tagStart = case extra of + NONE => tagStart + | SOME extra => (L'.EStrcat (tagStart, extra), loc) + + val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full + + fun normal () = + let + val (xml, fm) = monoExp (env, st, fm) xml + + val xml = case extraString of + NONE => xml + | SOME extra => (L'.EStrcat (extra, xml), loc) + in + ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), + (L'.EStrcat (xml, + strH (String.concat ["</", firstWord tag, ">"])), loc)), + loc), + fm) + end + + fun isSingleton () = + let + val (bef, aft) = Substring.splitl (not o Char.isSpace) (Substring.full tag) + in + SS.member (singletons, if Substring.isEmpty aft then + tag + else + Substring.string bef) + end + in + case (xml, extraString) of + ((L.EApp ((L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), + _), _), + _), _), + (L.EPrim (Prim.String (_, s)), _)), _), NONE) => + if CharVector.all Char.isSpace s andalso isSingleton () then + ((L'.EStrcat (tagStart, strH " />"), loc), fm) + else + normal () + | _ => normal () + end + + fun setAttrs jexp = + let + val s = strH (String.concat ["<", tag]) + + val assgns = List.mapPartial + (fn ("Source", _, _) => NONE + | ("Onchange", e, _) => + SOME (strcat [str "addOnChange(d,exec(", + (L'.EJavaScript (L'.Script, e), loc), + str "));"]) + | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) => + SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("), + (L'.EJavaScript (L'.Script, e), loc), + str ");"]) + | (x, e, _) => + if String.isPrefix "On" x then + let + val arg = if String.isPrefix "Onkey" x then + SOME (L'.EFfiApp ("Basis", "keyEvent", []), loc) + else if String.isSuffix "click" x orelse String.isPrefix "Onmouse" x then + SOME (L'.EFfiApp ("Basis", "mouseEvent", []), loc) + else + NONE + + val e = liftExpInExp 0 e + + val e = case arg of + NONE => e + | SOME arg => (L'.EApp (e, arg), loc) + + val e = (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.EApp (e, (L'.ERecord [], loc)), loc)), loc) + in + case x of + "Onkeyup" => + SOME (strcat [str ("((function(c){addOnKeyUp(d,function(ev){window.uw_event=ev?ev:window.event;return c();});})(exec("), + (L'.EJavaScript (L'.Script, e), loc), + str ")));"]) + | _ => + SOME (strcat [str ("((function(c){d." ^ lowercaseFirst x ^ "=function(ev){window.uw_event=ev?ev:window.event;return c();};})(exec("), + (L'.EJavaScript (L'.Script, e), loc), + str ")));"]) + end + else + SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("), + (L'.EJavaScript (L'.Script, e), loc), + str ");"])) + attrs + + val t = (L'.TFfi ("Basis", "string"), loc) + val setClass = (L'.ECase (class, + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), + ((L'.PVar ("x", t), loc), + (L'.EStrcat (strH "d.className=\"", + (L'.EStrcat ((L'.ERel 0, loc), + strH "\";"), loc)), + loc))], + {disc = (L'.TOption t, loc), + result = t}), loc) + in + case assgns of + [] => strcat [str "var d=", + jexp, + str ";", + setClass] + | _ => strcat (str "var d=" + :: jexp + :: str ";" + :: setClass + :: assgns) + end + + fun execify e = + case e of + NONE => strH "" + | SOME e => + let + val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) + in + (L'.EStrcat (strH "exec(", + (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), + strH ")"), loc)), loc) + end + + fun inTag tag' = case ctxOuter of + (L.CRecord (_, ctx), _) => + List.exists (fn ((L.CName tag'', _), _) => tag'' = tag' + | _ => false) ctx + | _ => false + + fun pnode () = if inTag "Tr" then + "tr" + else if inTag "Table" then + "table" + else + "span" + + fun cinput (fallback, dynamic) = + case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + strH (" type=\"" ^ fallback ^ "\" />")), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str (dynamic ^ "(exec("), + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end + + val baseAll as (base, fm) = + case tag of + "body" => let + val onload = execify onload + val onunload = execify onunload + val s = (L'.TFfi ("Basis", "string"), loc) + in + normal ("body", + SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", + [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", + [((L'.ERecord [], loc), + (L'.TRecord [], loc))]), loc), + onload), loc), + s)]), + loc), + (L'.EFfiApp ("Basis", "maybe_onunload", + [(onunload, s)]), + loc)), loc)) + end + + | "dyn" => + let + in + case attrs of + [("Signal", e, _)] => + ((L'.EStrcat + (strH ("<script type=\"text/javascript\">dyn(\"" + ^ pnode () ^ "\", execD("), + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + strH ("))</script>")), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad <dyn> attributes" + end + + | "active" => + (case attrs of + [("Code", e, _)] => + ((L'.EStrcat + (strH "<script type=\"text/javascript\">active(execD(", + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + strH "))</script>"), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad <active> attributes") + + | "script" => + (case attrs of + [("Code", e, _)] => + ((L'.EStrcat + (strH "<script type=\"text/javascript\">execF(execD(", + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + strH "))</script>"), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad <script> attributes") + + | "submit" => normal ("input type=\"submit\"", NONE) + | "image" => normal ("input type=\"image\"", NONE) + | "hidden" => input "hidden" + + | "textbox" => + (case targs of + [_, (L.CName name, _)] => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + strH (" type=\"text\" name=\"" ^ name ^ "\" />")), + loc), fm) + end + | SOME (_, src, _) => + (strcat [str "<script type=\"text/javascript\">inp(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "), \"", + str name, + str "\")</script>"], + fm)) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to textbox tag")) + | "password" => input "password" + | "email" => input "email" + | "search" => input "search" + | "url_" => input "url" + | "tel" => input "tel" + | "color" => input "color" + | "number" => input "number" + | "range" => input "range" + | "date" => input "date" + | "datetime" => input "datetime" + | "datetime_local" => input "datetime-local" + | "month" => input "month" + | "week" => input "week" + | "timeInput" => input "time" + | "textarea" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "textarea" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + strH (" name=\"" ^ name ^ "\">")), loc), + (L'.EStrcat (xml, + strH "</textarea>"), loc)), + loc), fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to ltextarea tag")) + + | "checkbox" => input "checkbox" + | "upload" => input "file" + + | "radio" => + (case targs of + [_, (L.CName name, _)] => + monoExp (env, St.setRadioGroup (st, name), fm) xml + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to radio tag")) + | "radioOption" => + (case St.radioGroup st of + NONE => raise Fail "No name for radioGroup" + | SOME name => + normal ("input", + SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\"")))) + + | "select" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "select" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + strH (" name=\"" ^ name ^ "\">")), loc), + (L'.EStrcat (xml, + strH "</select>"), + loc)), + loc), + fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to lselect tag")) + + | "ctextbox" => cinput ("text", "inp") + | "cpassword" => cinput ("password", "password") + | "cemail" => cinput ("email", "email") + | "csearch" => cinput ("search", "search") + | "curl" => cinput ("url", "url") + | "ctel" => cinput ("tel", "tel") + | "ccolor" => cinput ("color", "color") + + | "cnumber" => cinput ("number", "number") + | "crange" => cinput ("range", "range") + | "cdate" => cinput ("date", "date") + | "cdatetime" => cinput ("datetime", "datetime") + | "cdatetime_local" => cinput ("datetime-local", "datetime_local") + | "cmonth" => cinput ("month", "month") + | "cweek" => cinput ("week", "week") + | "ctime" => cinput ("time", "time") + + | "ccheckbox" => cinput ("checkbox", "chk") + | "cselect" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (xml, fm) = monoExp (env, st, fm) xml + val (ts, fm) = tagStart "select" + in + (strcat [ts, + str ">", + xml, + str "</select>"], + fm) + end + | SOME (_, src, _) => + let + val (xml, fm) = monoExp (env, st, fm) xml + + val sc = strcat [str "sel(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "),exec(", + (L'.EJavaScript (L'.Script, xml), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "coption" => normal ("option", NONE) + + | "ctextarea" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "textarea" + in + ((L'.EStrcat (ts, + strH " />"), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "tbx(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "tabl" => normal ("table", NONE) + | _ => normal (tag, NONE) + + val (dynClass', dynStyle') = + case tag of + "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan), + (L'.ENone dummyTyp, ErrorMsg.dummySpan)) + | _ => (dynClass, dynStyle) + in + case #1 dynClass' of + L'.ENone _ => + (case #1 dynStyle' of + L'.ENone _ => baseAll + | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"", + str (pnode ()), + str "\",execD(", + (L'.EJavaScript (L'.Script, base), loc), + str "),null,execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str "))</script>"], + fm) + | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; + baseAll)) + | L'.ESome (_, dc) => + let + val e = case #1 dynStyle' of + L'.ENone _ => str "null" + | L'.ESome (_, ds) => strcat [str "execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str ")"] + | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; + str "null") + in + (strcat [str "<script type=\"text/javascript\">dynClass(\"", + str (pnode ()), + str "\",execD(", + (L'.EJavaScript (L'.Script, base), loc), + str "),execD(", + (L'.EJavaScript (L'.Script, dc), loc), + str "),", + e, + str ")</script>"], + fm) + end + | _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown"; + baseAll) + end + + | L.EApp ( + (L.EApp ((L.EApp ((L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "form"), _), _), _), + (L.CRecord (_, fields), _)), _), + id), _), + class), _), + xml) => + let + fun findSubmit (e, _) = + case e of + L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join"), + _), _), _), + _), _), + _), _), + _), _), + xml1), _), + xml2) => (case findSubmit xml1 of + Error => Error + | NotFound => findSubmit xml2 + | Found e => + case findSubmit xml2 of + NotFound => Found e + | _ => Error) + | L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), _), + _), _), + _), _), + _), _), + attrs), _), + _), _), + xml) => + (case #1 attrs of + L.ERecord xes => + (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t) + | _ => NONE) xes of + NONE => findSubmit xml + | SOME et => + case findSubmit xml of + NotFound => Found et + | _ => Error) + | _ => findSubmit xml) + | _ => NotFound + + val (func, action, fm) = case findSubmit xml of + NotFound => (0, strH "", fm) + | Error => raise Fail "Not ready for multi-submit lforms yet" + | Found (action, actionT) => + let + val func = case #1 action of + L.EClosure (n, _) => n + | _ => raise Fail "Monoize: Action is not a closure" + val actionT = monoType env actionT + val (action, fm) = monoExp (env, st, fm) action + val (action, fm) = urlifyExp env fm (action, actionT) + in + (func, + (L'.EStrcat (strH " action=\"", + (L'.EStrcat (action, + strH "\""), loc)), loc), + fm) + end + + val hasUpload = CoreUtil.Exp.exists {kind = fn _ => false, + con = fn _ => false, + exp = fn e => + case e of + L.EFfi ("Basis", "upload") => true + | _ => false} xml + + val (xml, fm) = monoExp (env, st, fm) xml + + val xml = + if IS.member (!readCookie, func) then + let + fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s + | _ => true) fields + + fun getSigName () = + let + fun getSigName' n = + let + val s = "Sig" ^ Int.toString n + in + if inFields s then + getSigName' (n + 1) + else + s + end + in + if inFields "Sig" then + getSigName' 0 + else + "Sig" + end + + val sigName = getSigName () + val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc) + val sigSet = (L'.EStrcat (strH ("<input type=\"hidden\" name=\"" + ^ sigName + ^ "\" value=\""), + sigSet), loc) + val sigSet = (L'.EStrcat (sigSet, + strH "\" />"), loc) + in + (L'.EStrcat (sigSet, xml), loc) + end + else + xml + + val action = if hasUpload then + (L'.EStrcat (action, + strH " enctype=\"multipart/form-data\""), loc) + else + action + + val stt = (L'.TFfi ("Basis", "string"), loc) + val (id, fm) = monoExp (env, st, fm) id + val (class, fm) = monoExp (env, st, fm) class + val action = (L'.EStrcat (action, + (L'.ECase (class, + [((L'.PNone stt, loc), + strH ""), + ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc), + (L'.EStrcat (strH " class=\"", + (L'.EStrcat ((L'.ERel 0, loc), + strH "\""), loc)), loc))], + {disc = (L'.TOption stt, loc), + result = stt}), loc)), loc) + in + ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"", + (L'.EStrcat ((L'.ECase (id, + [((L'.PNone stt, loc), + strH ""), + ((L'.PSome (stt, (L'.PVar ("id", stt), loc)), loc), + (L'.EStrcat (strH " id=\"", + (L'.EStrcat ((L'.ERel 0, loc), + strH "\""), loc)), loc))], + {disc = (L'.TOption stt, loc), + result = stt}), loc), + (L'.EStrcat (action, + strH ">"), loc)), loc)), loc), + (L'.EStrcat (xml, + strH "</form>"), loc)), loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ( + (L.EFfi ("Basis", "subform"), _), _), _), _), + _), _), _), (L.CName nm, loc)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("xml", s, s, + strcat [strH ("<input type=\"hidden\" name=\".b\" value=\"" + ^ nm ^ "\" />"), + (L'.ERel 0, loc), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), + loc), + fm) + end + + | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ( + (L.EFfi ("Basis", "subforms"), _), _), _), _), + _), _), _), (L.CName nm, loc)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("xml", s, s, + strcat [strH ("<input type=\"hidden\" name=\".s\" value=\"" + ^ nm ^ "\" />"), + (L'.ERel 0, loc), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), + loc), + fm) + end + + | L.ECApp ((L.ECApp ( + (L.EFfi ("Basis", "entry"), _), _), _), _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("xml", s, s, + strcat [strH ("<input type=\"hidden\" name=\".i\" value=\"1\" />"), + (L'.ERel 0, loc), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), + loc), + fm) + end + + | L.EApp ((L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "useMore"), _), _), _), + _), _), + _), _), + _), _), + xml) => monoExp (env, st, fm) xml + + | L.ECApp ((L.EFfi ("Basis", "error"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t, + (L'.EError ((L'.ERel 0, loc), t), loc)), loc), + fm) + end + | L.EApp ( + (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _), + (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) => + let + val t = monoType env t + val un = (L'.TRecord [], loc) + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), + (L'.EAbs ("_", un, t, + (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc), + (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc), + (L'.EReturnBlob {blob = NONE, + mimeType = (L'.ERel 1, loc), + t = t}, loc)), loc)), loc)), loc)), + loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) => + let + val t = monoType env t + val un = (L'.TRecord [], loc) + in + ((L'.EAbs ("b", (L'.TFfi ("Basis", "blob"), loc), + (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc), + (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), + (L'.EAbs ("_", un, t, + (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc), + mimeType = (L'.ERel 1, loc), + t = t}, loc)), loc)), loc)), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "redirect"), _), t) => + let + val t = monoType env t + val un = (L'.TRecord [], loc) + in + ((L'.EAbs ("url", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), + (L'.EAbs ("_", un, t, + (L'.ERedirect ((L'.ERel 1, loc), t), loc)), loc)), loc), + fm) + end + + | L.ECApp ((L.EFfi ("Basis", "serialize"), _), t) => + let + val t = monoType env t + val (e, fm) = urlifyExp env fm ((L'.ERel 0, loc), t) + in + ((L'.EAbs ("v", t, (L'.TFfi ("Basis", "string"), loc), e), loc), + fm) + end + | L.ECApp ((L.EFfi ("Basis", "deserialize"), _), t) => + let + val t = monoType env t + in + ((L'.EAbs ("v", (L'.TFfi ("Basis", "string"), loc), t, (L'.EUnurlify ((L'.ERel 0, loc), t, false), + loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "url", [(e, _)]) => + let + val (e, fm) = monoExp (env, st, fm) e + val (e, fm) = urlifyExp env fm (e, dummyTyp) + in + ((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm) + end + + | L.EApp (e1, e2) => + let + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (env, st, fm) e2 + in + ((L'.EApp (e1, e2), loc), fm) + end + | L.EAbs (x, dom, ran, e) => + let + val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e + in + ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm) + end + + | L.ECApp (e, _) => + let + val (e, fm) = monoExp (env, st, fm) e + in + case #1 e of + L'.EFfi _ => (e, fm) + | _ => poly () + end + | L.ECAbs _ => poly () + + | L.EFfi mx => ((L'.EFfi mx, loc), fm) + | L.EFfiApp (m, x, es) => + let + val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((e, monoType env t), fm) + end) fm es + in + ((L'.EFfiApp (m, x, es), loc), fm) + end + + | L.ERecord xes => + let + val (xes, fm) = ListUtil.foldlMap + (fn ((x, e, t), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((monoName env x, + e, + monoType env t), fm) + end) fm xes + + val xes = ListMergeSort.sort (fn ((x, _, _), (y, _, _)) => String.compare (x, y) = GREATER) xes + in + ((L'.ERecord xes, loc), fm) + end + | L.EField (e, x, _) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EField (e, monoName env x), loc), fm) + end + | L.EConcat _ => poly () + | L.ECut _ => poly () + | L.ECutMulti _ => poly () + + | L.ECase (e, pes, {disc, result}) => + let + val (e, fm) = monoExp (env, st, fm) e + val (pes, fm) = ListUtil.foldlMap + (fn ((p, e), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((monoPat env p, e), fm) + end) fm pes + in + ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm) + end + + | L.EWrite e => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), + (L'.EWrite (liftExpInExp 0 e), loc)), loc), fm) + end + + | L.EClosure (n, es) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => + monoExp (env, st, fm) e) + fm es + val e = (L'.EClosure (n, es), loc) + in + (e, fm) + end + + | L.ELet (x, t, e1, e2) => + let + val t' = monoType env t + val (e1, fm) = monoExp (env, st, fm) e1 + val (e2, fm) = monoExp (Env.pushERel env x t, st, fm) e2 + in + ((L'.ELet (x, t', e1, e2), loc), fm) + end + + | L.EServerCall (n, es, t, fmode) => + let + val t = monoType env t + val (_, ft, _, name) = Env.lookupENamed env n + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + + fun encodeArgs (es, ft, acc, fm) = + case (es, ft) of + ([], _) => (rev acc, fm) + | (e :: es, (L.TFun (dom, ran), _)) => + let + val (e, fm) = urlifyExp env fm (e, monoType env dom) + in + encodeArgs (es, ran, e + :: str "/" + :: acc, fm) + end + | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type" + + val (call, fm) = encodeArgs (es, ft, [], fm) + val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc)) + (str name) call + + val unit = (L'.TRecord [], loc) + + val eff = if IS.member (!readCookie, n) then + L'.ReadCookieWrite + else + L'.ReadOnly + + val e = (L'.EServerCall (call, t, eff, fmode), loc) + val e = liftExpInExp 0 e + val e = (L'.EAbs ("_", unit, unit, e), loc) + in + (e, fm) + end + + | L.EKAbs _ => poly () + | L.EKApp _ => poly () + end + +fun monoDecl (env, fm) (all as (d, loc)) = + let + fun poly () = + (E.errorAt loc "Unsupported declaration"; + Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; + NONE) + + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) + in + case d of + L.DCon _ => NONE + | L.DDatatype [("list", n, [_], [("Nil", _, NONE), + ("Cons", _, SOME (L.TRecord (L.CRecord (_, + [((L.CName "1", _), + (L.CRel 0, _)), + ((L.CName "2", _), + (L.CApp ((L.CNamed n', _), + (L.CRel 0, _)), + _))]), _), _))])] => + if n = n' then + NONE + else + poly () + | L.DDatatype dts => + let + val env' = Env.declBinds env all + val dts = map (fn (x, n, [], xncs) => + (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs) + | _ => (E.errorAt loc "Polymorphic datatype needed too late"; + Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; + ("", 0, []))) dts + val d = (L'.DDatatype dts, loc) + in + SOME (env', fm, [d]) + end + | L.DVal (x, n, t, e, s) => + let + val (e, fm) = monoExp (env, St.empty, fm) e + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DVal (x, n, monoType env t, e, s), loc)]) + end + | L.DValRec vis => + let + val vis = map (fn (x, n, t, e, s) => + let + fun maybeTransaction (t, e) = + case (#1 t, #1 e) of + (L.CApp ((L.CFfi ("Basis", "transaction"), _), _), _) => + SOME (L.EAbs ("_", + (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc), + t, + (L.EApp (CoreEnv.liftExpInExp 0 e, + (L.ERecord [], loc)), loc)), loc) + | (L.TFun (dom, ran), L.EAbs (x, _, _, e)) => + (case maybeTransaction (ran, e) of + NONE => NONE + | SOME e => SOME (L.EAbs (x, dom, ran, e), loc)) + | _ => NONE + in + (x, n, t, + case maybeTransaction (t, e) of + NONE => e + | SOME e => e, + s) + end) vis + + val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis + + val (vis, fm) = ListUtil.foldlMap + (fn ((x, n, t, e, s), fm) => + let + val (e, fm) = monoExp (env, St.empty, fm) e + in + ((x, n, monoType env t, e, s), fm) + end) + fm vis + in + SOME (env, + fm, + [(L'.DValRec vis, loc)]) + end + | L.DExport (ek, n, b) => + let + val (_, t, _, s) = Env.lookupENamed env n + + fun unwind (t, args) = + case #1 t of + L.TFun (dom, ran) => unwind (ran, dom :: args) + | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => + unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args) + | _ => (rev args, t) + + val (ts, ran) = unwind (t, []) + val ts = map (monoType env) ts + val ran = monoType env ran + in + SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran, b), loc)]) + end + | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = Settings.mangleSqlTable s + val e_name = str s + + val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (pe, fm) = monoExp (env, St.empty, fm) pe + val (ce, fm) = monoExp (env, St.empty, fm) ce + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DTable (s, xts, pe, ce), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) + end + | L.DTable _ => poly () + | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = Settings.mangleSqlTable s + val e_name = str s + + val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e + val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DView (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) + end + | L.DView _ => poly () + | L.DSequence (x, n, s) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = Settings.mangleSql s + val e = str s + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DSequence s, loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DDatabase _ => NONE + | L.DCookie (x, n, t, s) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = str s + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DCookie s, loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DStyle (x, n, s) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = strH s + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DStyle s, loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DTask (e1, e2) => + let + val (e1, fm) = monoExp (env, St.empty, fm) e1 + val (e2, fm) = monoExp (env, St.empty, fm) e2 + + val un = (L'.TRecord [], loc) + val t = if MonoUtil.Exp.exists {typ = fn _ => false, + exp = fn L'.EFfiApp ("Basis", "periodic", _) => + (if #persistent (Settings.currentProtocol ()) then + () + else + E.errorAt (#2 e1) + ("Periodic tasks aren't allowed in the selected protocol (" ^ #name (Settings.currentProtocol ()) ^ ")."); + true) + | _ => false} e1 then + (L'.TFfi ("Basis", "int"), loc) + else + un + + val e2 = (L'.EAbs ("$x", t, (L'.TFun (un, un), loc), + (L'.EAbs ("$y", un, un, + (L'.EApp ( + (L'.EApp (e2, (L'.ERel 1, loc)), loc), + (L'.ERel 0, loc)), loc)), loc)), loc) + in + SOME (env, + fm, + [(L'.DTask (e1, e2), loc)]) + end + | L.DPolicy e => + let + fun policies (e, fm) = + case #1 e of + L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) => + let + val (ps1, fm) = policies (e1, fm) + val (ps2, fm) = policies (e2, fm) + in + (ps1 @ ps2, fm) + end + | _ => + let + val (e, make) = + case #1 e of + L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) => + (e, L'.PolClient) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) => + (e, L'.PolInsert) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) => + (e, L'.PolDelete) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) => + (e, L'.PolUpdate) + | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) => + (e, L'.PolSequence) + | _ => (poly (); (e, L'.PolClient)) + + val (e, fm) = monoExp (env, St.empty, fm) e + in + ([(L'.DPolicy (make e), loc)], fm) + end + + val (ps, fm) = policies (e, fm) + in + SOME (env, fm, ps) + end + | L.DOnError n => SOME (env, + fm, + [(L'.DOnError n, loc)]) + end + +datatype expungable = Client | Channel + +fun monoize env file = + let + val () = pvars := RM.empty + + (* Calculate which exported functions need cookie signature protection *) + val rcook = foldl (fn ((d, _), rcook) => + case d of + L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n) + | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n) + | _ => rcook) + IS.empty file + val () = readCookie := rcook + + val loc = E.dummySpan + val client = (L'.TFfi ("Basis", "client"), loc) + val unit = (L'.TRecord [], loc) + + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) + + fun calcClientish xts = + foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) => + case #1 x of + L.CName x => + (case #1 t of + L.CFfi ("Basis", "client") => + (nullable, (x, Client) :: notNullable) + | L.CApp ((L.CFfi ("Basis", "option"), _), + (L.CFfi ("Basis", "client"), _)) => + ((x, Client) :: nullable, notNullable) + | L.CApp ((L.CFfi ("Basis", "channel"), _), _) => + (nullable, (x, Channel) :: notNullable) + | L.CApp ((L.CFfi ("Basis", "option"), _), + (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) => + ((x, Channel) :: nullable, notNullable) + | _ => st) + | _ => st) ([], []) xts + + fun expunger () = + let + val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc) + + fun doTable (tab, xts, e) = + case xts of + L.CRecord (_, xts) => + let + val (nullable, notNullable) = calcClientish xts + + fun cond (x, v) = + (L'.EStrcat ((L'.EStrcat (str ("((" + ^ Settings.mangleSql x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ ") = "), + target), loc), + str ")"), loc) + + val e = + foldl (fn ((x, v), e) => + (L'.ESeq ( + (L'.EDml ((L'.EStrcat ( + str ("UPDATE " + ^ Settings.mangleSql tab + ^ " SET " + ^ Settings.mangleSql x + ^ " = NULL WHERE "), + cond (x, v)), loc), L'.Error), loc), + e), loc)) + e nullable + + val e = + case notNullable of + [] => e + | eb :: ebs => + (L'.ESeq ( + (L'.EDml ((L'.EStrcat (str ("DELETE FROM " + ^ Settings.mangleSql tab + ^ " WHERE "), + foldl (fn (eb, s) => + (L'.EStrcat (str "(", + (L'.EStrcat (s, + (L'.EStrcat (str " OR ", + (L'.EStrcat (cond eb, + str ")"), + loc)), loc)), loc)), loc)) + (cond eb) + ebs), loc), + L'.Error), loc), + e), loc) + in + e + end + | _ => e + + val e = (L'.ERecord [], loc) + in + foldl (fn ((d, _), e) => + case d of + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) + | _ => e) e file + end + + fun initializer () = + let + fun doTable (tab, xts, e) = + case xts of + L.CRecord (_, xts) => + let + val (nullable, notNullable) = calcClientish xts + + val e = + case nullable of + [] => e + | (x, _) :: ebs => + (L'.ESeq ( + (L'.EDml (str + (foldl (fn ((x, _), s) => + s ^ ", " ^ Settings.mangleSql x ^ " = NULL") + ("UPDATE " + ^ Settings.mangleSql tab + ^ " SET " + ^ Settings.mangleSql x + ^ " = NULL") + ebs), L'.Error), loc), + e), loc) + + val e = + case notNullable of + [] => e + | eb :: ebs => + (L'.ESeq ( + (L'.EDml (str ("DELETE FROM " + ^ Settings.mangleSql tab), L'.Error), loc), + e), loc) + in + e + end + | _ => e + + val e = (L'.ERecord [], loc) + in + foldl (fn ((d, _), e) => + case d of + L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e) + | _ => e) e file + end + + val mname = CoreUtil.File.maxName file + 1 + val () = nextPvar := mname + + val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) => + case #1 d of + L.DDatabase s => + let + val (nExp, fm) = Fm.freshName fm + val (nIni, fm) = Fm.freshName fm + + val dExp = L'.DVal ("expunger", + nExp, + (L'.TFun (client, unit), loc), + (L'.EAbs ("cli", client, unit, expunger ()), loc), + "expunger") + val dIni = L'.DVal ("initializer", + nIni, + (L'.TFun (unit, unit), loc), + (L'.EAbs ("_", unit, unit, initializer ()), loc), + "initializer") + in + (env, Fm.enter fm, (L'.DDatabase {name = s, + expunge = nExp, + initialize = nIni}, loc) + :: (dExp, loc) + :: (dIni, loc) + :: ds) + end + | _ => + (pvarDefs := []; + pvarOldDefs := []; + case monoDecl (env, fm) d of + NONE => (env, fm, ds) + | SOME (env, fm, ds') => + (foldr (fn ((n, cs), env) => + Env.declBinds env (L.DDatatype [("$poly" ^ Int.toString n, + n, + [], + cs)], loc)) + env (!pvarOldDefs), + Fm.enter fm, + case ds' of + [(L'.DDatatype dts, loc)] => + (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds + | _ => + ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) + (env, Fm.empty mname, []) file + val monoFile = (rev ds, []) + in + pvars := RM.empty; + pvarDefs := []; + pvarOldDefs := []; + MonoFooify.canonicalFm := Fm.empty (MonoUtil.File.maxName monoFile + 1); + monoFile + end + +end diff --git a/src/multimap_fn.sml b/src/multimap_fn.sml new file mode 100644 index 0000000..3dab68a --- /dev/null +++ b/src/multimap_fn.sml @@ -0,0 +1,16 @@ +functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct + type key = KeyMap.Key.ord_key + type item = ValSet.item + type itemSet = ValSet.set + type multimap = ValSet.set KeyMap.map + val empty : multimap = KeyMap.empty + fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap = + KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) + fun insert (kToVs : multimap, k : key, v : item) : multimap = + insertSet (kToVs, k, ValSet.singleton v) + fun findSet (kToVs : multimap, k : key) = + case KeyMap.find (kToVs, k) of + SOME vs => vs + | NONE => ValSet.empty + val findList : multimap * key -> item list = ValSet.listItems o findSet +end diff --git a/src/mysql.sig b/src/mysql.sig new file mode 100644 index 0000000..fa254ae --- /dev/null +++ b/src/mysql.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 MYSQL = sig + +end diff --git a/src/mysql.sml b/src/mysql.sml new file mode 100644 index 0000000..52e4921 --- /dev/null +++ b/src/mysql.sml @@ -0,0 +1,1614 @@ +(* Copyright (c) 2009-2010, 2015, 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 MySQL :> MYSQL = struct + +open Settings +open Print.PD +open Print + +fun p_sql_type t = + case t of + Int => "bigint" + | Float => "double" + | String => "longtext" + | Char => "char" + | Bool => "bool" + | Time => "timestamp" + | Blob => "longblob" + | Channel => "bigint" + | Client => "int" + | Nullable t => p_sql_type t + +fun p_buffer_type t = + case t of + Int => "MYSQL_TYPE_LONGLONG" + | Float => "MYSQL_TYPE_DOUBLE" + | String => "MYSQL_TYPE_STRING" + | Char => "MYSQL_TYPE_STRING" + | Bool => "MYSQL_TYPE_LONG" + | Time => "MYSQL_TYPE_TIMESTAMP" + | Blob => "MYSQL_TYPE_BLOB" + | Channel => "MYSQL_TYPE_LONGLONG" + | Client => "MYSQL_TYPE_LONG" + | Nullable t => p_buffer_type t + +fun p_sql_type_base t = + case t of + Int => "bigint" + | Float => "double" + | String => "longtext" + | Char => "char" + | Bool => "tinyint" + | Time => "timestamp" + | Blob => "longblob" + | Channel => "bigint" + | Client => "int" + | Nullable t => p_sql_type_base t + +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +fun checkRel (table, checkNullable) (s, xts) = + let + val sl = CharVector.map Char.toLower s + val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then + String.substring (sl, 1, size sl - 2) + else + sl + val both = "table_name = '" ^ sl ^ "'" + + val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE " ^ both + + val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ", + both, + " AND (", + case String.concatWith " OR " + (map (fn (x, t) => + String.concat ["(LOWER(column_name) = '", + Settings.mangleSqlCatalog + (CharVector.map + Char.toLower (ident x)), + "' AND data_type ", + case p_sql_type_base t of + "bigint" => + "IN ('bigint', 'int')" + | "longtext" => + "IN ('longtext', 'varchar')" + | s => "= '" ^ s ^ "'", + if checkNullable then + (" AND is_nullable = '" + ^ (if isNotNull t then + "NO" + else + "YES") + ^ "'") + else + "", + ")"]) xts) of + "" => "FALSE" + | s => s, + ")"] + + val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE ", + both, + " AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"] + in + box [string "if (mysql_query(conn->conn, \"", + string q, + string "\")) {", + newline, + box [string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((res = mysql_store_result(conn->conn)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Result store failed:\\n", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if (mysql_num_fields(res) != 1) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Bad column count:\\n", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((row = mysql_fetch_row(res)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Row fetch failed:\\n", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if (strcmp(row[0], \"1\")) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "mysql_free_result(res);", + newline, + newline, + + string "if (mysql_query(conn->conn, \"", + string q', + string "\")) {", + newline, + box [string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q', + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((res = mysql_store_result(conn->conn)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Result store failed:\\n", + string q', + string "\");", + newline], + string "}", + newline, + newline, + + string "if (mysql_num_fields(res) != 1) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Bad column count:\\n", + string q', + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((row = mysql_fetch_row(res)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Row fetch failed:\\n", + string q', + string "\");", + newline], + string "}", + newline, + newline, + + string "if (strcmp(row[0], \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' has the wrong column types.\");", + newline], + string "}", + newline, + newline, + string "mysql_free_result(res);", + newline, + newline, + + string "if (mysql_query(conn->conn, \"", + string q'', + string "\")) {", + newline, + box [string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q'', + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((res = mysql_store_result(conn->conn)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Result store failed:\\n", + string q'', + string "\");", + newline], + string "}", + newline, + newline, + + string "if (mysql_num_fields(res) != 1) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Bad column count:\\n", + string q'', + string "\");", + newline], + string "}", + newline, + newline, + + string "if ((row = mysql_fetch_row(res)) == NULL) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Row fetch failed:\\n", + string q'', + string "\");", + newline], + string "}", + newline, + newline, + + string "if (strcmp(row[0], \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "mysql_free_result(res);", + newline, + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' has extra columns.\");", + newline], + string "}", + newline, + newline, + string "mysql_free_result(res);", + newline] + end + +fun init {dbstring, prepared = ss, tables, views, sequences} = + let + val host = ref NONE + val user = ref NONE + val passwd = ref NONE + val db = ref NONE + val port = ref NONE + val unix_socket = ref NONE + + fun stringOf r = case !r of + NONE => string "NULL" + | SOME s => box [string "\"", + string (Prim.toCString s), + string "\""] + in + app (fn s => + case String.fields (fn ch => ch = #"=") s of + [name, value] => + (case name of + "host" => + if size value > 0 andalso String.sub (value, 0) = #"/" then + unix_socket := SOME value + else + host := SOME value + | "hostaddr" => host := SOME value + | "port" => port := Int.fromString value + | "dbname" => db := SOME value + | "user" => user := SOME value + | "password" => passwd := SOME value + | _ => ()) + | _ => ()) (String.tokens Char.isSpace dbstring); + + box [string "typedef struct {", + newline, + box [string "MYSQL *conn;", + newline, + p_list_sepi (box []) + (fn i => fn _ => + box [string "MYSQL_STMT *p", + string (Int.toString i), + string ";", + newline]) + ss], + string "} uw_conn;", + newline, + newline, + + string "static void uw_client_init(void) {", + newline, + box [string "uw_sqlfmtInt = \"%lld%n\";", + newline, + string "uw_sqlfmtFloat = \"%.16g%n\";", + newline, + string "uw_Estrings = 0;", + newline, + string "uw_sql_type_annotations = 0;", + newline, + string "uw_sqlsuffixString = \"\";", + newline, + string "uw_sqlsuffixChar = \"\";", + newline, + string "uw_sqlsuffixBlob = \"\";", + newline, + string "uw_sqlfmtUint4 = \"%u%n\";", + newline, + newline, + + string "if (mysql_library_init(0, NULL, NULL)) {", + newline, + box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");", + newline, + string "exit(1);", + newline], + string "}", + newline], + string "}", + newline, + newline, + + if #persistent (currentProtocol ()) then + box [string "static void uw_db_validate(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_RES *res;", + newline, + string "MYSQL_ROW row;", + newline, + newline, + p_list_sep newline (checkRel ("tables", true)) tables, + p_list_sep newline (fn name => checkRel ("tables", true) + (name, [("id", Settings.Client)])) sequences, + p_list_sep newline (checkRel ("views", false)) views, + string "}", + newline, + newline, + + string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_STMT *stmt;", + newline, + newline, + + p_list_sepi newline (fn i => fn (s, _) => + let + fun uhoh this s args = + box [p_list_sepi (box []) + (fn j => fn () => + box [string + "mysql_stmt_close(conn->p", + string (Int.toString j), + string ");", + newline]) + (List.tabulate (i, fn _ => ())), + box (if this then + [string + "mysql_stmt_close(conn->p", + string (Int.toString i), + string ");", + newline] + else + []), + string "mysql_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"", + string s, + string "\"", + p_list_sep (box []) (fn s => box [string ", ", + string s]) args, + string ");", + newline] + in + box [string "stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) {", + newline, + uhoh false "Out of memory allocating prepared statement" [], + string "}", + newline, + string "conn->p", + string (Int.toString i), + string " = stmt;", + newline, + + string "if (mysql_stmt_prepare(stmt, \"", + string (Prim.toCString s), + string "\", ", + string (Int.toString (size s)), + string ")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_stmt_error(stmt), 1024);", + newline, + string "msg[1023] = 0;", + newline, + uhoh true "Error preparing statement: %s" ["msg"]], + string "}", + newline] + end) + ss, + + string "}"] + else + box [string "static void uw_db_prepare(uw_context ctx) { }", + newline, + string "static void uw_db_validate(uw_context ctx) { }"], + newline, + newline, + + string "static void uw_db_init(uw_context ctx) {", + newline, + string "MYSQL *mysql = mysql_init(NULL);", + newline, + string "uw_conn *conn;", + newline, + string "if (mysql == NULL) uw_error(ctx, FATAL, ", + string "\"libmysqlclient can't allocate a connection.\");", + newline, + string "if (mysql_real_connect(mysql, ", + stringOf host, + string ", ", + stringOf user, + string ", ", + stringOf passwd, + string ", ", + stringOf db, + string ", ", + case !port of + NONE => string "0" + | SOME n => string (Int.toString n), + string ", ", + stringOf unix_socket, + string ", CLIENT_MULTI_STATEMENTS) == NULL) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_error(mysql), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "mysql_close(mysql);", + newline, + string "uw_error(ctx, FATAL, ", + string "\"Connection to MySQL server failed: %s\", msg);"], + newline, + string "}", + newline, + newline, + string "if (mysql_set_character_set(mysql, \"utf8\")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_error(mysql), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "mysql_close(mysql);", + newline, + string "uw_error(ctx, FATAL, ", + string "\"Error setting UTF-8 character set for MySQL connection: %s\", msg);"], + newline, + string "}", + newline, + newline, + string "conn = calloc(1, sizeof(uw_conn));", + newline, + string "conn->conn = mysql;", + newline, + string "uw_set_db(ctx, conn);", + newline, + string "uw_db_validate(ctx);", + newline, + string "uw_db_prepare(ctx);", + newline, + string "}", + newline, + newline, + + string "static void uw_db_close(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + p_list_sepi (box []) + (fn i => fn _ => + box [string "if (conn->p", + string (Int.toString i), + string ") mysql_stmt_close(conn->p", + string (Int.toString i), + string ");", + newline]) + ss, + string "mysql_close(conn->conn);", + newline, + string "}", + newline, + newline, + + string "static int uw_db_begin(uw_context ctx, int could_write) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + newline, + string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE; BEGIN\") ? 1 : (mysql_next_result(conn->conn), 0);", + newline, + string "}", + newline, + newline, + + string "static int uw_db_commit(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "return mysql_commit(conn->conn);", + newline, + string "}", + newline, + newline, + + string "static int uw_db_rollback(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "return mysql_rollback(conn->conn);", + newline, + string "}", + newline, + newline] + end + +fun p_getcol {loc, wontLeakStrings = _, col = i, typ = t} = + let + fun getter t = + case t of + String => box [string "({", + newline, + string "uw_Basis_string s = uw_malloc(ctx, length", + string (Int.toString i), + string " + 1);", + newline, + string "out[", + string (Int.toString i), + string "].buffer = s;", + newline, + string "out[", + string (Int.toString i), + string "].buffer_length = length", + string (Int.toString i), + string " + 1;", + newline, + string "mysql_stmt_fetch_column(stmt, &out[", + string (Int.toString i), + string "], ", + string (Int.toString i), + string ", 0);", + newline, + string "s[length", + string (Int.toString i), + string "] = 0;", + newline, + string "s;", + newline, + string "})"] + | Blob => box [string "({", + newline, + string "uw_Basis_blob b = {length", + string (Int.toString i), + string ", uw_malloc(ctx, length", + string (Int.toString i), + string ")};", + newline, + string "out[", + string (Int.toString i), + string "].buffer = b.data;", + newline, + string "out[", + string (Int.toString i), + string "].buffer_length = length", + string (Int.toString i), + string ";", + newline, + string "mysql_stmt_fetch_column(stmt, &out[", + string (Int.toString i), + string "], ", + string (Int.toString i), + string ", 0);", + newline, + string "b;", + newline, + string "})"] + | Time => box [string "({", + string "MYSQL_TIME *mt = &buffer", + string (Int.toString i), + string ";", + newline, + newline, + string "struct tm t = {mt->second, mt->minute, mt->hour, mt->day, mt->month-1, mt->year - 1900, 0, 0, -1};", + newline, + string "uw_Basis_time res = {mktime(&t), 0};", + newline, + string "res;", + newline, + string "})"] + | Channel => box [string "({", + string "uw_Basis_channel ch = {buffer", + string (Int.toString i), + string " >> 32, buffer", + string (Int.toString i), + string " & 0xFFFFFFFF};", + newline, + string "ch;", + newline, + string "})"] + | _ => box [string "buffer", + string (Int.toString i)] + in + case t of + Nullable t => box [string "(is_null", + string (Int.toString i), + string " ? NULL : ", + case t of + String => getter t + | _ => box [string "({", + newline, + string (p_sql_ctype t), + space, + string "*tmp = uw_malloc(ctx, sizeof(", + string (p_sql_ctype t), + string "));", + newline, + string "*tmp = ", + getter t, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + | _ => box [string "(is_null", + string (Int.toString i), + string " ? ", + box [string "({", + string (p_sql_ctype t), + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #", + string (Int.toString i), + string "\");", + newline, + string "tmp;", + newline, + string "})"], + string " : ", + getter t, + string ")"] + end + +fun queryCommon {loc, query, cols, doCols} = + box [string "int n, r;", + newline, + string "MYSQL_BIND out[", + string (Int.toString (length cols)), + string "];", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "unsigned long length", + string (Int.toString i), + string ";", + newline] + | Blob => box [string "unsigned long length", + string (Int.toString i), + string ";", + newline] + | Time => box [string "MYSQL_TIME buffer", + string (Int.toString i), + string ";", + newline] + | Channel => box [string "unsigned long long buffer", + string (Int.toString i), + string ";", + newline] + | _ => box [string (p_sql_ctype t), + space, + string "buffer", + string (Int.toString i), + string ";", + newline] + in + box [string "my_bool is_null", + string (Int.toString i), + string ";", + newline, + case t of + Nullable t => buffers t + | _ => buffers t, + newline] + end) cols, + newline, + + string "memset(out, 0, sizeof out);", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "out[", + string (Int.toString i), + string "].length = &length", + string (Int.toString i), + string ";", + newline] + | Char => box [string "out[", + string (Int.toString i), + string "].buffer_length = 1;", + newline, + string "out[", + string (Int.toString i), + string "].buffer = &buffer", + string (Int.toString i), + string ";", + newline] + | Blob => box [string "out[", + string (Int.toString i), + string "].length = &length", + string (Int.toString i), + string ";", + newline] + | _ => box [string "out[", + string (Int.toString i), + string "].buffer = &buffer", + string (Int.toString i), + string ";", + newline] + in + box [string "out[", + string (Int.toString i), + string "].buffer_type = ", + string (p_buffer_type t), + string ";", + newline, + string "out[", + string (Int.toString i), + string "].is_null = &is_null", + string (Int.toString i), + string ";", + newline, + + case t of + Nullable t => buffers t + | _ => buffers t, + newline] + end) cols, + newline, + + string "if (mysql_stmt_reset(stmt)) {", + box [newline, + string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error resetting statement: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline], + string "}", + newline, + newline, + + string "if (mysql_stmt_execute(stmt)) {", + newline, + box [string "if (mysql_errno(conn->conn) == 1213)", + newline, + box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", + newline], + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error executing query: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline], + string "}", + newline, + newline, + + string "if (mysql_stmt_bind_result(stmt, out)) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error binding query result: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline, + newline, + + string "if (mysql_stmt_store_result(stmt)) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error storing query result: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline, + newline, + + string "uw_end_region(ctx);", + newline, + string "while (1) {", + newline, + string "r = mysql_stmt_fetch(stmt);", + newline, + string "if (r != 0 && r != MYSQL_DATA_TRUNCATED) break;", + newline, + doCols p_getcol, + string "}", + newline, + newline, + + string "if (r == 1) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": query result fetching failed: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline, + newline, + + string "if (mysql_stmt_reset(stmt)) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error resetting statement: %s\\n%s\", ", + query, + string ", mysql_error(conn->conn));", + newline, + newline] + +fun query {loc, cols, doCols} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_STMT *stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": can't allocate temporary prepared statement\");", + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);", + newline, + string "if (mysql_stmt_prepare(stmt, query, strlen(query))) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error preparing statement: %s\\n%s\", query, mysql_error(conn->conn));", + newline, + newline, + + queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}, + + string "uw_pop_cleanup(ctx);", + newline] + +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_BIND in[", + string (Int.toString (length inputs)), + string "];", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "unsigned long in_length", + string (Int.toString i), + string ";", + newline] + | Blob => box [string "unsigned long in_length", + string (Int.toString i), + string ";", + newline] + | Time => box [string "MYSQL_TIME in_buffer", + string (Int.toString i), + string ";", + newline] + | _ => box [] + in + box [case t of + Nullable t => box [string "my_bool in_is_null", + string (Int.toString i), + string ";", + newline, + buffers t] + | _ => buffers t, + newline] + end) inputs, + + if nested then + box [string "MYSQL_STMT *stmt;", + newline] + else + box [string "MYSQL_STMT *stmt = conn->p", + string (Int.toString id), + string ";", + newline, + newline, + + string "if (stmt == NULL) {", + newline], + + box [string "stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");", + newline, + if nested then + box [string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);", + newline] + else + box [], + string "if (mysql_stmt_prepare(stmt, \"", + string (Prim.toCString query), + string "\", ", + string (Int.toString (size query)), + string ")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_stmt_error(stmt), 1024);", + newline, + string "msg[1023] = 0;", + newline, + if nested then + box [] + else + box [string "mysql_stmt_close(stmt);", + newline], + string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);", + newline], + string "}", + newline, + if nested then + box [] + else + box [string "conn->p", + string (Int.toString id), + string " = stmt;", + newline]], + if nested then + box [] + else + box [string "}", + newline], + newline, + + string "memset(in, 0, sizeof in);", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "in[", + string (Int.toString i), + string "].buffer = arg", + string (Int.toString (i + 1)), + string ";", + newline, + string "in_length", + string (Int.toString i), + string "= in[", + string (Int.toString i), + string "].buffer_length = strlen(arg", + string (Int.toString (i + 1)), + string ");", + newline, + string "in[", + string (Int.toString i), + string "].length = &in_length", + string (Int.toString i), + string ";", + newline] + | Char => box [string "in[", + string (Int.toString i), + string "].buffer = &arg", + string (Int.toString (i + 1)), + string ";", + newline, + string "in[", + string (Int.toString i), + string "].buffer_length = 1;", + newline] + | Blob => box [string "in[", + string (Int.toString i), + string "].buffer = arg", + string (Int.toString (i + 1)), + string ".data;", + newline, + string "in_length", + string (Int.toString i), + string "= in[", + string (Int.toString i), + string "].buffer_length = arg", + string (Int.toString (i + 1)), + string ".size;", + newline, + string "in[", + string (Int.toString i), + string "].length = &in_length", + string (Int.toString i), + string ";", + newline] + | Time => + let + fun oneField dst src = + box [string "in_buffer", + string (Int.toString i), + string ".", + string dst, + string " = tms.tm_", + string src, + string ";", + newline] + in + box [string "({", + newline, + string "struct tm tms;", + newline, + string "if (localtime_r(&arg", + string (Int.toString (i + 1)), + string ".seconds, &tms) == NULL) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error converting to MySQL time\");", + newline, + oneField "year" "year + 1900", + box [string "in_buffer", + string (Int.toString i), + string ".month = tms.tm_mon + 1;", + newline], + oneField "day" "mday", + oneField "hour" "hour", + oneField "minute" "min", + oneField "second" "sec", + newline, + string "in[", + string (Int.toString i), + string "].buffer = &in_buffer", + string (Int.toString i), + string ";", + newline, + string "});", + newline] + end + | Channel => box [string "in_buffer", + string (Int.toString i), + string " = ((unsigned long long)arg", + string (Int.toString (i + 1)), + string ".cli << 32) | arg", + string (Int.toString (i + 1)), + string ".chn;", + newline, + string "in[", + string (Int.toString i), + string "].buffer = &in_buffer", + string (Int.toString i), + string ";", + newline] + + | _ => box [string "in[", + string (Int.toString i), + string "].buffer = &arg", + string (Int.toString (i + 1)), + string ";", + newline] + in + box [string "in[", + string (Int.toString i), + string "].buffer_type = ", + string (p_buffer_type t), + string ";", + newline, + + case t of + Nullable t => box [string "in[", + string (Int.toString i), + string "].is_null = &in_is_null", + string (Int.toString i), + string ";", + newline, + string "if (arg", + string (Int.toString (i + 1)), + string " == NULL) {", + newline, + box [string "in_is_null", + string (Int.toString i), + string " = 1;", + newline], + string "} else {", + box [case t of + String => box [] + | _ => + box [string (p_sql_ctype t), + space, + string "tmp = *arg", + string (Int.toString (i + 1)), + string ";", + newline, + string (p_sql_ctype t), + space, + string "arg", + string (Int.toString (i + 1)), + string " = tmp;", + newline], + string "in_is_null", + string (Int.toString i), + string " = 0;", + newline, + buffers t, + newline], + string "}", + newline] + + | _ => buffers t, + newline] + end) inputs, + newline, + + string "if (mysql_stmt_bind_param(stmt, in)) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error binding parameters\");", + newline, + + queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", + string (Prim.toCString query), + string "\""]}, + + if nested then + box [string "uw_pop_cleanup(ctx);", + newline] + else + box []] + +fun dmlCommon {loc, dml, mode} = + box [string "if (mysql_stmt_execute(stmt)) {", + box [string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);", + newline, + string "if (mysql_errno(conn->conn) == 1213)", + newline, + box [string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", + newline], + newline, + case mode of + Settings.Error => box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error executing DML: %s\\n%s\", ", + dml, + string ", mysql_error(conn->conn));"] + | Settings.None => string "uw_set_error_message(ctx, mysql_error(conn->conn));", + newline], + string "}", + newline] + +fun dml (loc, mode) = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_STMT *stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": can't allocate temporary prepared statement\");", + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))mysql_stmt_close, stmt);", + newline, + string "if (mysql_stmt_prepare(stmt, dml, strlen(dml))) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error preparing statement: %s\\n%s\", dml, mysql_error(conn->conn));", + newline, + newline, + + dmlCommon {loc = loc, dml = string "dml", mode = mode}, + + string "uw_pop_cleanup(ctx);", + newline] + +fun dmlPrepared {loc, id, dml, inputs, mode} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "MYSQL_BIND in[", + string (Int.toString (length inputs)), + string "];", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "unsigned long in_length", + string (Int.toString i), + string ";", + newline] + | Blob => box [string "unsigned long in_length", + string (Int.toString i), + string ";", + newline] + | Time => box [string "MYSQL_TIME in_buffer", + string (Int.toString i), + string ";", + newline] + | Channel => box [string "unsigned long long in_buffer", + string (Int.toString i), + string ";", + newline] + | _ => box [] + in + box [case t of + Nullable t => box [string "my_bool in_is_null", + string (Int.toString i), + string ";", + newline, + buffers t] + | _ => buffers t, + newline] + end) inputs, + string "MYSQL_STMT *stmt = conn->p", + string (Int.toString id), + string ";", + newline, + newline, + + string "if (stmt == NULL) {", + newline, + box [string "stmt = mysql_stmt_init(conn->conn);", + newline, + string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");", + newline, + string "if (mysql_stmt_prepare(stmt, \"", + string (Prim.toCString dml), + string "\", ", + string (Int.toString (size dml)), + string ")) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, mysql_stmt_error(stmt), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "uw_error(ctx, FATAL, \"Error preparing statement: %s\", msg);", + newline], + string "}", + newline, + string "conn->p", + string (Int.toString id), + string " = stmt;", + newline], + string "}", + newline, + newline, + + string "memset(in, 0, sizeof in);", + newline, + p_list_sepi (box []) (fn i => fn t => + let + fun buffers t = + case t of + String => box [string "in[", + string (Int.toString i), + string "].buffer = arg", + string (Int.toString (i + 1)), + string ";", + newline, + string "in_length", + string (Int.toString i), + string "= in[", + string (Int.toString i), + string "].buffer_length = strlen(arg", + string (Int.toString (i + 1)), + string ");", + newline, + string "in[", + string (Int.toString i), + string "].length = &in_length", + string (Int.toString i), + string ";", + newline] + | Blob => box [string "in[", + string (Int.toString i), + string "].buffer = arg", + string (Int.toString (i + 1)), + string ".data;", + newline, + string "in_length", + string (Int.toString i), + string "= in[", + string (Int.toString i), + string "].buffer_length = arg", + string (Int.toString (i + 1)), + string ".size;", + newline, + string "in[", + string (Int.toString i), + string "].length = &in_length", + string (Int.toString i), + string ";", + newline] + | Time => + let + fun oneField dst src = + box [string "in_buffer", + string (Int.toString i), + string ".", + string dst, + string " = tms.tm_", + string src, + string ";", + newline] + in + box [string "({", + newline, + string "struct tm tms;", + newline, + string "if (localtime_r(&arg", + string (Int.toString (i + 1)), + string ".seconds, &tms) == NULL) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error converting to MySQL time\");", + newline, + oneField "year" "year + 1900", + oneField "month" "mon + 1", + oneField "day" "mday", + oneField "hour" "hour", + oneField "minute" "min", + oneField "second" "sec", + newline, + string "in[", + string (Int.toString i), + string "].buffer = &in_buffer", + string (Int.toString i), + string ";", + newline, + string "});", + newline] + end + | Channel => box [string "in_buffer", + string (Int.toString i), + string " = ((unsigned long long)arg", + string (Int.toString (i + 1)), + string ".cli << 32) | arg", + string (Int.toString (i + 1)), + string ".chn;", + newline, + string "in[", + string (Int.toString i), + string "].buffer = &in_buffer", + string (Int.toString i), + string ";", + newline] + + | _ => box [string "in[", + string (Int.toString i), + string "].buffer = &arg", + string (Int.toString (i + 1)), + string ";", + newline] + in + box [string "in[", + string (Int.toString i), + string "].buffer_type = ", + string (p_buffer_type t), + string ";", + newline, + + case t of + Channel => box [string "in[", + string (Int.toString i), + string "].is_unsigned = 1;", + newline] + | _ => box [], + + case t of + Nullable t => box [string "in[", + string (Int.toString i), + string "].is_null = &in_is_null", + string (Int.toString i), + string ";", + newline, + string "if (arg", + string (Int.toString (i + 1)), + string " == NULL) {", + newline, + box [string "in_is_null", + string (Int.toString i), + string " = 1;", + newline], + string "} else {", + box [case t of + String => box [] + | _ => + box [string (p_sql_ctype t), + space, + string "tmp = *arg", + string (Int.toString (i + 1)), + string ";", + newline, + string (p_sql_ctype t), + space, + string "arg", + string (Int.toString (i + 1)), + string " = tmp;", + newline], + string "in_is_null", + string (Int.toString i), + string " = 0;", + newline, + buffers t, + newline], + string "}", + newline] + + | _ => buffers t, + newline] + end) inputs, + newline, + + string "if (mysql_stmt_bind_param(stmt, in)) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": error binding parameters\");", + newline, + + dmlCommon {loc = loc, dml = box [string "\"", + string (Prim.toCString dml), + string "\""], mode = mode}] + +fun nextval {loc, seqE, seqName} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "char *insert = ", + case seqName of + SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES ()\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ", + seqE, + string ", \" VALUES ()\"))"], + string ";", + newline, + string "char *delete = ", + case seqName of + SOME s => string ("\"DELETE FROM " ^ s ^ "\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ", + seqE, + string ")"], + string ";", + newline, + newline, + + string "if (mysql_query(conn->conn, insert)) {", + box [newline, + string "if (mysql_errno(conn->conn) == 2006) uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"'nextval' INSERT failed\");", + newline], + string "}", + newline, + string "n = mysql_insert_id(conn->conn);", + newline, + string "if (mysql_query(conn->conn, delete)) uw_error(ctx, FATAL, \"'nextval' DELETE failed\");", + newline] + +fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called" + +fun setval _ = raise Fail "MySQL.setval called" + +fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'" + | #"\\" => "\\\\" + | ch => + if Char.isPrint ch then + str ch + else + (ErrorMsg.error + "Non-printing character found in SQL string literal"; + "")) + (Prim.toCString s) ^ "'" + +fun p_cast (s, _) = s + +fun p_blank _ = "?" + +val () = addDbms {name = "mysql", + header = Config.msheader, + randomFunction = "RAND", + link = "-lmysqlclient", + init = init, + p_sql_type = p_sql_type, + query = query, + queryPrepared = queryPrepared, + dml = dml, + dmlPrepared = dmlPrepared, + nextval = nextval, + nextvalPrepared = nextvalPrepared, + setval = setval, + sqlifyString = sqlifyString, + p_cast = p_cast, + p_blank = p_blank, + supportsDeleteAs = false, + supportsUpdateAs = false, + createSequence = fn s => "CREATE TABLE " ^ s ^ " (uw_id INTEGER PRIMARY KEY AUTO_INCREMENT)", + textKeysNeedLengths = true, + supportsNextval = false, + supportsNestedPrepared = false, + sqlPrefix = "SET storage_engine=InnoDB;\n\n", + supportsOctetLength = true, + trueString = "TRUE", + falseString = "FALSE", + onlyUnion = true, + nestedRelops = false, + windowFunctions = false, + supportsIsDistinctFrom = true} + +end diff --git a/src/name_js.sig b/src/name_js.sig new file mode 100644 index 0000000..6750b7a --- /dev/null +++ b/src/name_js.sig @@ -0,0 +1,35 @@ +(* 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. + *) + +(* Phase that introduces names for fragments of JavaScript code, so that they + * may be moved to app.js and not repeated in each generated page *) + +signature NAME_JS = sig + + val rewrite : Mono.file -> Mono.file + +end diff --git a/src/name_js.sml b/src/name_js.sml new file mode 100644 index 0000000..f10e593 --- /dev/null +++ b/src/name_js.sml @@ -0,0 +1,173 @@ +(* Copyright (c) 2012-2013, 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. + *) + +(* Phase that introduces names for fragments of JavaScript code, so that they + * may be moved to app.js and not repeated in each generated page *) + +structure NameJS :> NAME_JS = struct + +open Mono + +structure U = MonoUtil +structure IS = IntBinarySet + +val freeVars = U.Exp.foldB {typ = #2, + exp = fn (free, e, vs) => + case e of + ERel n => + if n < free then + vs + else + IS.add (vs, n - free) + | _ => vs, + bind = fn (free, b) => + case b of + U.Exp.RelE _ => free+1 + | _ => free} + 0 IS.empty + +fun index (ls, v) = + case ls of + [] => raise Fail "NameJs.index" + | v' :: ls' => if v = v' then 0 else 1 + index (ls', v) + +fun squish vs = U.Exp.mapB {typ = fn x => x, + exp = fn free => fn e => + case e of + ERel n => + if n < free then + e + else + ERel (free + index (vs, n - free) + 1) + | _ => e, + bind = fn (free, b) => + case b of + U.Exp.RelE _ => free+1 + | _ => free} + 0 + +fun rewrite file = + let + fun isTricky' dontName e = + case e of + ENamed n => IS.member (dontName, n) + | EFfiApp ("Basis", "sigString", _) => true + | _ => false + + fun isTricky dontName = U.Decl.exists {typ = fn _ => false, + exp = isTricky' dontName, + decl = fn _ => false} + + fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false, + exp = isTricky' dontName} + + val dontName = foldl (fn (d, dontName) => + if isTricky dontName d then + case #1 d of + DVal (_, n, _, _, _) => IS.add (dontName, n) + | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis + | _ => dontName + else + dontName) IS.empty (#1 file) + + val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => + let + val (d, (nextName, newDs)) = + U.Decl.foldMapB {typ = fn x => x, + decl = fn (_, e, s) => (e, s), + exp = fn (env, e, st as (nextName, newDs)) => + case e of + EJavaScript (mode, e') => + (case mode of + Source _ => (e, st) + | _ => + let + fun isTrulySimple (e, _) = + case e of + ERel _ => true + | ENamed _ => true + | ERecord [] => true + | _ => false + + fun isAlreadySimple e = + case #1 e of + EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e + | _ => isTrulySimple e + in + if isAlreadySimple e' orelse isTrickyE dontName e' then + (e, st) + else + let + val loc = #2 e' + + val vs = freeVars e' + val vs = IS.listItems vs + + val x = "script" ^ Int.toString nextName + + val un = (TRecord [], loc) + val s = (TFfi ("Basis", "string"), loc) + val base = (TFun (un, s), loc) + val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs + val e' = squish vs e' + val e' = (EAbs ("_", un, s, e'), loc) + val (e', _) = foldl (fn (n, (e', t)) => + let + val (x, this) = List.nth (env, n) + in + ((EAbs (x, this, t, e'), loc), + (TFun (this, t), loc)) + end) (e', base) vs + val d = (x, nextName, t, e', "<script>") + + val e = (ENamed nextName, loc) + val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs + val e = (EApp (e, (ERecord [], loc)), loc) + val e = EJavaScript (Script, e) + in + (e, (nextName+1, d :: newDs)) + end + end) + | _ => (e, st), + bind = fn (env, b) => + case b of + U.Decl.RelE x => x :: env + | _ => env} + [] (nextName, []) d + in + (case newDs of + [] => [d] + | _ => case #1 d of + DValRec vis => [(DValRec (vis @ newDs), #2 d)] + | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), + nextName) + end) (U.File.maxName file + 1) (#1 file) + in + (ds, #2 file) + end + +end diff --git a/src/option_key_fn.sml b/src/option_key_fn.sml new file mode 100644 index 0000000..27ba913 --- /dev/null +++ b/src/option_key_fn.sml @@ -0,0 +1,12 @@ +functor OptionKeyFn(K : ORD_KEY) + : ORD_KEY where type ord_key = K.ord_key option = struct + +type ord_key = K.ord_key option + +val compare = + fn (NONE, NONE) => EQUAL + | (NONE, _) => LESS + | (_, NONE) => GREATER + | (SOME x, SOME y) => K.compare (x, y) + +end diff --git a/src/order.sig b/src/order.sig new file mode 100644 index 0000000..fcee69e --- /dev/null +++ b/src/order.sig @@ -0,0 +1,36 @@ +(* Copyright (c) 2008, 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. + *) + +(* Utility code for implementing comparisons *) + +signature ORDER = sig + + val join : order * (unit -> order) -> order + val joinL : ('a * 'b -> order) -> 'a list * 'b list -> order + val joinO : ('a * 'b -> order) -> 'a option * 'b option -> order + +end diff --git a/src/order.sml b/src/order.sml new file mode 100644 index 0000000..3f5bce6 --- /dev/null +++ b/src/order.sml @@ -0,0 +1,53 @@ +(* Copyright (c) 2008, 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. + *) + +(* Utility code for implementing comparisons *) + +structure Order :> ORDER = struct + +fun join (o1, o2) = + case o1 of + EQUAL => o2 () + | v => v + +fun joinL f (os1, os2) = + case (os1, os2) of + (nil, nil) => EQUAL + | (nil, _) => LESS + | (h1 :: t1, h2 :: t2) => + join (f (h1, h2), fn () => joinL f (t1, t2)) + | (_ :: _, nil) => GREATER + +fun joinO f (v1, v2) = + case (v1, v2) of + (NONE, NONE) => EQUAL + | (NONE, _) => LESS + | (_, NONE) => GREATER + + | (SOME v1, SOME v2) => f (v1, v2) + +end diff --git a/src/pair_key_fn.sml b/src/pair_key_fn.sml new file mode 100644 index 0000000..cd33950 --- /dev/null +++ b/src/pair_key_fn.sml @@ -0,0 +1,12 @@ +functor PairKeyFn (structure I : ORD_KEY + structure J : ORD_KEY) + : ORD_KEY where type ord_key = I.ord_key * J.ord_key = struct + +type ord_key = I.ord_key * J.ord_key + +fun compare ((i1, j1), (i2, j2)) = + case I.compare (i1, i2) of + EQUAL => J.compare (j1, j2) + | ord => ord + +end diff --git a/src/pathcheck.sig b/src/pathcheck.sig new file mode 100644 index 0000000..e4b9c7a --- /dev/null +++ b/src/pathcheck.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 PATH_CHECK = sig + + val check : Mono.file -> unit + +end diff --git a/src/pathcheck.sml b/src/pathcheck.sml new file mode 100644 index 0000000..3533032 --- /dev/null +++ b/src/pathcheck.sml @@ -0,0 +1,115 @@ +(* Copyright (c) 2008, 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 PathCheck :> PATH_CHECK = struct + +open Mono + +structure E = ErrorMsg + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = + let + fun doFunc s = + (if SS.member (funcs, s) then + E.errorAt loc ("Duplicate function path " ^ s) + else + (); + (SS.add (funcs, s), rels, cookies, styles)) + + fun doRel s = + (if SS.member (rels, s) then + E.errorAt loc ("Duplicate table/sequence path " ^ s) + else + (); + (funcs, SS.add (rels, s), cookies, styles)) + + fun doCookie s = + (if SS.member (cookies, s) then + E.errorAt loc ("Duplicate cookie path " ^ s) + else + (); + (funcs, rels, SS.add (cookies, s), styles)) + + fun doStyle s = + (if SS.member (styles, s) then + E.errorAt loc ("Duplicate style path " ^ s) + else + (); + (funcs, rels, cookies, SS.add (styles, s))) + in + case d of + DExport (_, s, _, _, _, _) => doFunc s + + | DTable (s, _, pe, ce) => + let + fun constraints (e, rels) = + case #1 e of + ERecord [(s', _, _)] => + let + val s' = s ^ "_" ^ s' + in + if SS.member (rels, s') then + E.errorAt loc ("Duplicate constraint path " ^ s') + else + (); + SS.add (rels, s') + end + | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels)) + | _ => rels + + val rels = #2 (doRel s) + val rels = case #1 pe of + EPrim (Prim.String (_, "")) => rels + | _ => + let + val s' = s ^ "_Pkey" + in + if SS.member (rels, s') then + E.errorAt loc ("Duplicate primary key constraint path " ^ s') + else + (); + SS.add (rels, s') + end + in + (funcs, constraints (ce, rels), cookies, styles) + end + | DSequence s => doRel s + + | DCookie s => doCookie s + | DStyle s => doStyle s + + | _ => (funcs, rels, cookies, styles) + end + +fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) + +end diff --git a/src/postgres.sig b/src/postgres.sig new file mode 100644 index 0000000..54117f0 --- /dev/null +++ b/src/postgres.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 POSTGRES = sig + +end diff --git a/src/postgres.sml b/src/postgres.sml new file mode 100644 index 0000000..404384d --- /dev/null +++ b/src/postgres.sml @@ -0,0 +1,1153 @@ +(* 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 Postgres :> POSTGRES = struct + +open Settings +open Print.PD +open Print + +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +fun p_sql_type t = + case t of + Int => "int8" + | Float => "float8" + | String => "text" + | Char => "char" + | Bool => "bool" + | Time => "timestamp" + | Blob => "bytea" + | Channel => "int8" + | Client => "int4" + | Nullable t => p_sql_type t + +fun p_sql_type_base t = + case t of + Int => "bigint" + | Float => "double precision" + | String => "text" + | Char => "character" + | Bool => "boolean" + | Time => "timestamp without time zone" + | Blob => "bytea" + | Channel => "bigint" + | Client => "integer" + | Nullable t => p_sql_type_base t + +fun checkRel (table, checkNullable) (s, xts) = + let + val sl = CharVector.map Char.toLower s + val sl = if size sl > 1 andalso String.sub (sl, 0) = #"\"" then + String.substring (sl, 1, size sl - 2) + else + sl + + val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '" + ^ sl ^ "'" + + val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", + sl, + "' AND (", + case String.concatWith " OR " + (map (fn (x, t) => + String.concat ["(LOWER(column_name) = '", + Settings.mangleSqlCatalog + (CharVector.map + Char.toLower (ident x)), + (case p_sql_type_base t of + "bigint" => + "' AND data_type IN ('bigint', 'numeric', 'integer')" + | "text" => + "' AND data_type IN ('text', 'character varying')" + | t => + String.concat ["' AND data_type = '", + t, + "'"]), + if checkNullable then + (" AND is_nullable = '" + ^ (if isNotNull t then + "NO" + else + "YES") + ^ "'") + else + "", + ")"]) xts) of + "" => "FALSE" + | s => s, + ")"] + + val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", + sl, + "' AND LOWER(column_name) LIKE '", Settings.mangleSqlCatalog "%'"] + in + box [string "res = PQexec(conn, \"", + string q, + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline, + + string "res = PQexec(conn, \"", + string q', + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q', + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' has the wrong column types.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline, + newline, + + string "res = PQexec(conn, \"", + string q'', + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q'', + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"", + string (Int.toString (length xts)), + string "\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string sl, + string "' has extra columns.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline] + end + +fun init {dbstring, prepared = ss, tables, views, sequences} = + box [if #persistent (currentProtocol ()) then + box [string "static void uw_db_validate(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res;", + newline, + newline, + p_list_sep newline (checkRel ("tables", true)) tables, + p_list_sep newline (checkRel ("views", false)) views, + + p_list_sep newline + (fn s => + let + val sl = CharVector.map Char.toLower s + + val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" + ^ sl ^ "' AND relkind = 'S' AND pg_catalog.pg_table_is_visible(oid)" + in + box [string "res = PQexec(conn, \"", + string q, + string "\");", + newline, + newline, + string "if (res == NULL) {", + newline, + box [string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Query failed:\\n", + string q, + string "\\n%s\", msg);", + newline], + string "}", + newline, + newline, + string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", + newline, + box [string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Sequence '", + string s, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "PQclear(res);", + newline] + end) sequences, + + string "}", + + string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res;", + newline, + newline, + + p_list_sepi newline (fn i => fn (s, _) => + box [string "res = PQprepare(conn, \"uw", + string (Int.toString i), + string "\", \"", + string (Prim.toCString s), + string "\", 0, NULL);", + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQclear(res);", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n", + string (Prim.toCString s), + string "\\n%s\", msg);", + newline], + string "}", + newline, + string "PQclear(res);", + newline]) + ss, + + string "}", + newline, + newline] + else + box [string "static void uw_db_validate(uw_context ctx) { }", + newline, + string "static void uw_db_prepare(uw_context ctx) { }"], + + string "static void uw_client_init(void) {", + newline, + box [string "uw_sqlfmtInt = \"%lld::int8%n\";", + newline, + string "uw_sqlfmtFloat = \"%.16g::float8%n\";", + newline, + string "uw_Estrings = 1;", + newline, + string "uw_sql_type_annotations = 1;", + newline, + string "uw_sqlsuffixString = \"::text\";", + newline, + string "uw_sqlsuffixChar = \"::char\";", + newline, + string "uw_sqlsuffixBlob = \"::bytea\";", + newline, + string "uw_sqlfmtUint4 = \"%u::int4%n\";", + newline], + string "}", + newline, + newline, + + string "static void uw_db_close(uw_context ctx) {", + newline, + string "PQfinish(uw_get_db(ctx));", + newline, + string "}", + newline, + newline, + + string "static int uw_db_begin(uw_context ctx, int could_write) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, could_write ? \"BEGIN ISOLATION LEVEL SERIALIZABLE\" : \"BEGIN ISOLATION LEVEL SERIALIZABLE, READ ONLY\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + string "return 0;", + newline, + string "}", + newline, + newline, + + string "static int uw_db_commit(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"COMMIT\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {", + box [newline, + string "PQclear(res);", + newline, + string "return -1;", + newline], + string "}", + newline, + string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {", + box [newline, + string "PQclear(res);", + newline, + string "return -1;", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + string "return 0;", + newline, + string "}", + newline, + newline, + + string "static int uw_db_rollback(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"ROLLBACK\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + string "return 0;", + newline, + string "}", + + newline, + newline, + + string "static void uw_db_init(uw_context ctx) {", + newline, + string "char *env_db_str = getenv(\"URWEB_PQ_CON\");", + newline, + string "PGconn *conn = PQconnectdb(env_db_str == NULL ? \"", + string (Prim.toCString dbstring), + string "\" : env_db_str);", + newline, + string "if (conn == NULL) uw_error(ctx, FATAL, ", + string "\"libpq can't allocate a connection.\");", + newline, + string "if (PQstatus(conn) != CONNECTION_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, PQerrorMessage(conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + string "PQfinish(conn);", + newline, + string "uw_error(ctx, BOUNDED_RETRY, ", + string "\"Connection to Postgres server failed: %s\", msg);"], + newline, + string "}", + newline, + string "uw_set_db(ctx, conn);", + newline, + string "uw_db_validate(ctx);", + newline, + string "uw_db_prepare(ctx);", + newline, + string "}"] + +fun p_getcol {loc, wontLeakStrings, col = i, typ = t} = + let + fun p_unsql t e eLen = + case t of + Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] + | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] + | String => + if wontLeakStrings then + e + else + box [string "uw_strdup(ctx, ", e, string ")"] + | Char => box [e, string "[0]"] + | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] + | Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"] + | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ", + e, + string ", ", + eLen, + string ")"] + | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] + | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] + + | Nullable _ => raise Fail "Postgres: Recursive Nullable" + + fun getter t = + case t of + Nullable t => + box [string "(PQgetisnull(res, i, ", + string (Int.toString i), + string ") ? NULL : ", + case t of + String => getter t + | _ => box [string "({", + newline, + string (p_sql_ctype t), + space, + string "*tmp = uw_malloc(ctx, sizeof(", + string (p_sql_ctype t), + string "));", + newline, + string "*tmp = ", + getter t, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + | _ => + box [string "(PQgetisnull(res, i, ", + string (Int.toString i), + string ") ? ", + box [string "({", + string (p_sql_ctype t), + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Unexpectedly NULL field #", + string (Int.toString i), + string "\");", + newline, + string "tmp;", + newline, + string "})"], + string " : ", + p_unsql t + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + (box [string "PQgetlength(res, i, ", + string (Int.toString i), + string ")"]), + string ")"] + in + getter t + end + +fun queryCommon {loc, query, cols, doCols} = + box [string "int n, i;", + newline, + newline, + + string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate query result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {", + box [newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");", + newline], + string "}", + newline, + string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {", + box [newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query failed:\\n%s\\n%s\", ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "if (PQnfields(res) != ", + string (Int.toString (length cols)), + string ") {", + newline, + box [string "int nf = PQnfields(res);", + newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query returned %d columns instead of ", + string (Int.toString (length cols)), + string ":\\n%s\\n%s\", nf, ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "uw_end_region(ctx);", + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);", + newline, + string "n = PQntuples(res);", + newline, + string "for (i = 0; i < n; ++i) {", + newline, + doCols p_getcol, + string "}", + newline, + newline, + string "uw_pop_cleanup(ctx);", + newline] + +fun query {loc, cols, doCols} = + box [string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}] + +fun p_ensql t e = + case t of + Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] + | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] + | String => e + | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"] + | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] + | Time => box [string "uw_Basis_ensqlTime(ctx, ", e, string ")"] + | Blob => box [e, string ".data"] + | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"] + | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"] + | Nullable String => e + | Nullable t => box [string "(", + e, + string " == NULL ? NULL : ", + p_ensql t (box [string "(*", e, string ")"]), + string ")"] + +fun makeParams inputs = + box [string "static const int paramFormats[] = { ", + p_list_sep (box [string ",", space]) + (fn t => if isBlob t then string "1" else string "0") inputs, + string " };", + newline, + if List.exists isBlob inputs then + box [string "int *paramLengths = uw_malloc(ctx, ", + string (Int.toString (length inputs)), + string " * sizeof(int));", + newline, + p_list_sepi (box []) + (fn i => fn t => + box [string "paramLengths[", + string (Int.toString i), + string "] = ", + case t of + Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size") + | Nullable Blob => string ("arg" ^ Int.toString (i + 1) + ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") + | _ => string "0", + string ";", + newline]) inputs, + newline] + else + box [string "const int *paramLengths = paramFormats;", + newline], + + string "const char **paramValues = uw_malloc(ctx, ", + string (Int.toString (length inputs)), + string " * sizeof(char*));", + newline, + p_list_sepi (box []) + (fn i => fn t => box [string "paramValues[", + string (Int.toString i), + string "] = ", + p_ensql t (box [string "arg", + string (Int.toString (i + 1))]), + string ";", + newline]) + inputs, + newline] + +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = + box [string "PGconn *conn = uw_get_db(ctx);", + newline, + + makeParams inputs, + + newline, + string "PGresult *res = ", + if #persistent (Settings.currentProtocol ()) then + box [string "PQexecPrepared(conn, \"uw", + string (Int.toString id), + string "\", ", + string (Int.toString (length inputs)), + string ", paramValues, paramLengths, paramFormats, 0);"] + else + box [string "PQexecParams(conn, \"", + string (Prim.toCString query), + string "\", ", + string (Int.toString (length inputs)), + string ", NULL, paramValues, paramLengths, paramFormats, 0);"], + newline, + newline, + queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", + string (Prim.toCString query), + string "\""]}] + +fun dmlCommon {loc, dml, mode} = + box [string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate DML result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + newline, + box [string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {", + box [newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");", + newline], + string "}", + newline, + string "if (!strcmp_nullsafe(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {", + box [newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", + newline], + string "}", + newline, + case mode of + Settings.Error => box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": DML failed:\\n%s\\n%s\", ", + dml, + string ", PQerrorMessage(conn));"] + | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));", + newline, + newline, + + string "res = PQexec(conn, \"ROLLBACK TO s\");", + newline, + string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate DML ROLLBACK result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": ROLLBACK TO failed:\\n%s\\n%s\", ", + dml, + string ", PQerrorMessage(conn));", + newline, + string "}"], + newline, + + string "PQclear(res);", + newline], + newline], + string "}", + + case mode of + Error => box [newline, + newline, + string "PQclear(res);", + newline] + | None => box[string " else {", + newline, + box [string "PQclear(res);", + newline, + string "res = PQexec(conn, \"RELEASE s\");", + newline, + string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate DML RELEASE result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": RELEASE failed:\\n%s\\n%s\", ", + dml, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + string "PQclear(res);", + newline], + string "}", + newline]] + +fun makeSavepoint mode = + case mode of + Error => box [] + | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");", + newline, + string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate DML SAVEPOINT result; database server may be down.\");", + newline], + string "}", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [newline, + string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");", + newline], + string "}", + newline, + string "PQclear(res);", + newline, + newline] + +fun dml (loc, mode) = + box [string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res;", + newline, + + makeSavepoint mode, + + string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + dmlCommon {loc = loc, dml = string "dml", mode = mode}] + +fun dmlPrepared {loc, id, dml, inputs, mode} = + box [string "PGconn *conn = uw_get_db(ctx);", + newline, + + makeParams inputs, + + newline, + string "PGresult *res;", + newline, + newline, + + makeSavepoint mode, + + string "res = ", + if #persistent (Settings.currentProtocol ()) then + box [string "PQexecPrepared(conn, \"uw", + string (Int.toString id), + string "\", ", + string (Int.toString (length inputs)), + string ", paramValues, paramLengths, paramFormats, 0);"] + else + box [string "PQexecParams(conn, \"", + string (Prim.toCString dml), + string "\", ", + string (Int.toString (length inputs)), + string ", NULL, paramValues, paramLengths, paramFormats, 0);"], + newline, + newline, + dmlCommon {loc = loc, dml = box [string "\"", + string (Prim.toCString dml), + string "\""], mode = mode}] + +fun nextvalCommon {loc, query} = + box [string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate NEXTVAL result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query failed:\\n%s\\n%s\", ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "n = PQntuples(res);", + newline, + string "if (n != 1) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Wrong number of result rows:\\n%s\\n%s\", ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));", + newline, + string "PQclear(res);", + newline] + +open Cjr + +fun nextval {loc, seqE, seqName} = + let + val query = case seqName of + SOME s => + string ("\"SELECT NEXTVAL('" ^ s ^ "')\"") + | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ", + seqE, + string ", \"')\"))"] + in + box [string "char *query = ", + query, + string ";", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + nextvalCommon {loc = loc, query = string "query"}] + end + +fun nextvalPrepared {loc, id, query} = + box [string "PGconn *conn = uw_get_db(ctx);", + newline, + newline, + string "PGresult *res = ", + if #persistent (Settings.currentProtocol ()) then + box [string "PQexecPrepared(conn, \"uw", + string (Int.toString id), + string "\", 0, NULL, NULL, NULL, 0);"] + else + box [string "PQexecParams(conn, \"", + string (Prim.toCString query), + string "\", 0, NULL, NULL, NULL, NULL, 0);"], + newline, + newline, + nextvalCommon {loc = loc, query = box [string "\"", + string (Prim.toCString query), + string "\""]}] + +fun setvalCommon {loc, query} = + box [string "if (res == NULL) {", + box [newline, + string "uw_try_reconnecting_and_restarting(ctx);", + newline, + string "uw_error(ctx, FATAL, \"Can't allocate SETVAL result; database server may be down.\");", + newline], + string "}", + newline, + newline, + + string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", + newline, + box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Query failed:\\n%s\\n%s\", ", + query, + string ", PQerrorMessage(conn));", + newline], + string "}", + newline, + newline, + + string "PQclear(res);", + newline] + +fun setval {loc, seqE, count} = + let + val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ", + seqE, + string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ", + count, + string "), \")\"))))"] + in + box [string "char *query = ", + query, + string ";", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", + newline, + newline, + setvalCommon {loc = loc, query = string "query"}] + end + +fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" + | #"\\" => "\\\\" + | ch => + if Char.isPrint ch then + str ch + else + "\\" ^ StringCvt.padLeft #"0" 3 + (Int.fmt StringCvt.OCT (ord ch))) + (Prim.toCString s) ^ "'::text" + +fun p_cast (s, t) = s ^ "::" ^ p_sql_type t + +fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t) + +val () = addDbms {name = "postgres", + randomFunction = "RANDOM", + header = Config.pgheader, + link = "-lpq", + p_sql_type = p_sql_type, + init = init, + query = query, + queryPrepared = queryPrepared, + dml = dml, + dmlPrepared = dmlPrepared, + nextval = nextval, + nextvalPrepared = nextvalPrepared, + setval = setval, + sqlifyString = sqlifyString, + p_cast = p_cast, + p_blank = p_blank, + supportsDeleteAs = true, + supportsUpdateAs = true, + createSequence = fn s => "CREATE SEQUENCE " ^ s, + textKeysNeedLengths = false, + supportsNextval = true, + supportsNestedPrepared = true, + sqlPrefix = "", + supportsOctetLength = true, + trueString = "TRUE", + falseString = "FALSE", + onlyUnion = false, + nestedRelops = true, + windowFunctions = true, + supportsIsDistinctFrom = true} + +val () = setDbms "postgres" + +end diff --git a/src/prefix.cm b/src/prefix.cm new file mode 100644 index 0000000..2e71d07 --- /dev/null +++ b/src/prefix.cm @@ -0,0 +1,7 @@ +Group is + +$/basis.cm +$/smlnj-lib.cm +$smlnj/ml-yacc/ml-yacc-lib.cm +$/pp-lib.cm + diff --git a/src/prefix.mlb b/src/prefix.mlb new file mode 100644 index 0000000..6a51048 --- /dev/null +++ b/src/prefix.mlb @@ -0,0 +1,7 @@ +local + $(SML_LIB)/basis/basis.mlb + $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb + $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb + $(SML_LIB)/smlnj-lib/PP/pp-lib.mlb +in + diff --git a/src/prepare.sig b/src/prepare.sig new file mode 100644 index 0000000..0977100 --- /dev/null +++ b/src/prepare.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 PREPARE = sig + + val prepare : Cjr.file -> Cjr.file + +end diff --git a/src/prepare.sml b/src/prepare.sml new file mode 100644 index 0000000..660173f --- /dev/null +++ b/src/prepare.sml @@ -0,0 +1,356 @@ +(* Copyright (c) 2008, 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 Prepare :> PREPARE = struct + +open Cjr +open Settings + +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +structure St :> sig + type t + val empty : t + val nameOf : t * string -> t * int + val list : t -> (string * int) list + val count : t -> int +end = struct + +type t = {map : int SM.map, list : (string * int) list, count : int} + +val empty = {map = SM.empty, list = [], count = 0} + +fun nameOf (t as {map, list, count}, s) = + case SM.find (map, s) of + NONE => ({map = SM.insert (map, s, count), list = (s, count) :: list, count = count + 1}, count) + | SOME n => (t, n) + +fun list (t : t) = rev (#list t) +fun count (t : t) = #count t + +end + +fun prepString (e, st) = + let + fun prepString' (e, ss, n) = + let + fun doOne t = + SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1) + in + case #1 e of + EPrim (Prim.String (_, s)) => + SOME (s :: ss, n) + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => + (case prepString' (e1, ss, n) of + NONE => NONE + | SOME (ss, n) => prepString' (e2, ss, n)) + | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int + | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float + | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String + | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool + | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time + | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob + | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel + | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client + + | ECase (e, + [((PNone _, _), + (EPrim (Prim.String (_, "NULL")), _)), + ((PSome (_, (PVar _, _)), _), + (EFfiApp (m, x, [((ERel 0, _), _)]), _))], + {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n) + + | ECase (e, + [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), + (EPrim (Prim.String (_, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), + (EPrim (Prim.String (_, "FALSE")), _))], + _) => doOne Bool + + | _ => NONE + end + in + case prepString' (e, [], 0) of + NONE => NONE + | SOME (ss, n) => + let + val s = String.concat (rev ss) + val (st, id) = St.nameOf (st, s) + in + SOME (id, s, st) + end + end + +fun prepExp (e as (_, loc), st) = + case #1 e of + EPrim _ => (e, st) + | ERel _ => (e, st) + | ENamed _ => (e, st) + | ECon (_, _, NONE) => (e, st) + | ECon (dk, pc, SOME e) => + let + val (e, st) = prepExp (e, st) + in + ((ECon (dk, pc, SOME e), loc), st) + end + | ENone t => (e, st) + | ESome (t, e) => + let + val (e, st) = prepExp (e, st) + in + ((ESome (t, e), loc), st) + end + | EFfi _ => (e, st) + | EFfiApp (m, x, es) => + let + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = prepExp (e, st) + in + ((e, t), st) + end) st es + in + ((EFfiApp (m, x, es), loc), st) + end + | EApp (e1, es) => + let + val (e1, st) = prepExp (e1, st) + val (es, st) = ListUtil.foldlMap prepExp st es + in + ((EApp (e1, es), loc), st) + end + + | EUnop (s, e1) => + let + val (e1, st) = prepExp (e1, st) + in + ((EUnop (s, e1), loc), st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = prepExp (e1, st) + val (e2, st) = prepExp (e2, st) + in + ((EBinop (s, e1, e2), loc), st) + end + + | ERecord (rn, xes) => + let + val (xes, st) = ListUtil.foldlMap (fn ((x, e), st) => + let + val (e, st) = prepExp (e, st) + in + ((x, e), st) + end) st xes + in + ((ERecord (rn, xes), loc), st) + end + | EField (e, s) => + let + val (e, st) = prepExp (e, st) + in + ((EField (e, s), loc), st) + end + + | ECase (e, pes, ts) => + let + val (e, st) = prepExp (e, st) + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val (e, st) = prepExp (e, st) + in + ((p, e), st) + end) st pes + in + ((ECase (e, pes, ts), loc), st) + end + + | EError (e, t) => + let + val (e, st) = prepExp (e, st) + in + ((EError (e, t), loc), st) + end + + | EReturnBlob {blob, mimeType, t} => + let + val (blob, st) = case blob of + NONE => (blob, st) + | SOME blob => + let + val (b, st) = prepExp (blob, st) + in + (SOME b, st) + end + val (mimeType, st) = prepExp (mimeType, st) + in + ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) + end + + | ERedirect (e, t) => + let + val (e, st) = prepExp (e, st) + in + ((ERedirect (e, t), loc), st) + end + + | EWrite e => + let + val (e, st) = prepExp (e, st) + in + ((EWrite e, loc), st) + end + | ESeq (e1, e2) => + let + val (e1, st) = prepExp (e1, st) + val (e2, st) = prepExp (e2, st) + in + ((ESeq (e1, e2), loc), st) + end + | ELet (x, t, e1, e2) => + let + val (e1, st) = prepExp (e1, st) + val (e2, st) = prepExp (e2, st) + in + ((ELet (x, t, e1, e2), loc), st) + end + + | EQuery {exps, tables, rnum, state, query, body, initial, ...} => + let + val (body, st) = prepExp (body, st) + in + case prepString (query, st) of + NONE => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = NONE}, loc), + st) + | SOME (id, s, st) => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st) + end + + | EDml {dml, mode, ...} => + (case prepString (dml, st) of + NONE => (e, st) + | SOME (id, s, st) => + ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, loc), st)) + + | ENextval {seq, ...} => + if #supportsNextval (Settings.currentDbms ()) then + let + val s = case seq of + (EPrim (Prim.String (_, s)), loc) => + (EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val t = (TFfi ("Basis", "string"), loc) + val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String (Prim.Normal, "')")), loc), t)]), loc) + in + (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('")), loc), t), (s', t)]), loc) + end + in + case prepString (s, st) of + NONE => (e, st) + | SOME (id, s, st) => + ((ENextval {seq = seq, prepared = SOME {id = id, query = s}}, loc), st) + end + else + (e, st) + + | ESetval {seq = e1, count = e2} => + let + val (e1, st) = prepExp (e1, st) + val (e2, st) = prepExp (e2, st) + in + ((ESetval {seq = e1, count = e2}, loc), st) + end + + | EUnurlify (e, t, b) => + let + val (e, st) = prepExp (e, st) + in + ((EUnurlify (e, t, b), loc), st) + end + +fun prepDecl (d as (_, loc), st) = + case #1 d of + DStruct _ => (d, st) + | DDatatype _ => (d, st) + | DDatatypeForward _ => (d, st) + | DVal (x, n, t, e) => + let + val (e, st) = prepExp (e, st) + in + ((DVal (x, n, t, e), loc), st) + end + | DFun (x, n, xts, t, e) => + let + val (e, st) = prepExp (e, st) + in + ((DFun (x, n, xts, t, e), loc), st) + end + | DFunRec fs => + let + val (fs, st) = ListUtil.foldlMap (fn ((x, n, xts, t, e), st) => + let + val (e, st) = prepExp (e, st) + in + ((x, n, xts, t, e), st) + end) st fs + in + ((DFunRec fs, loc), st) + end + + | DTable _ => (d, st) + | DSequence _ => (d, st) + | DView _ => (d, st) + | DDatabase _ => (d, st) + | DPreparedStatements _ => (d, st) + | DJavaScript _ => (d, st) + | DCookie _ => (d, st) + | DStyle _ => (d, st) + | DTask (tk, x1, x2, e) => + let + val (e, st) = prepExp (e, st) + in + ((DTask (tk, x1, x2, e), loc), st) + end + | DOnError _ => (d, st) + +fun prepare (ds, ps) = + let + val (ds, st) = ListUtil.foldlMap prepDecl St.empty ds + in + ((DPreparedStatements (St.list st), ErrorMsg.dummySpan) :: ds, ps) + end + +end diff --git a/src/prim.sig b/src/prim.sig new file mode 100644 index 0000000..1da53d3 --- /dev/null +++ b/src/prim.sig @@ -0,0 +1,49 @@ +(* Copyright (c) 2008, 2014, 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 PRIM = sig + + datatype string_mode = Normal | Html + + datatype t = + Int of Int64.int + | Float of Real64.real + | String of string_mode * string + | Char of char + + val p_t : t Print.printer + val p_t_GCC : t Print.printer + + val equal : t * t -> bool + val compare : t * t -> order + + val toString : t -> string + + val toCString : string -> string + (* SML's built-in [String.toCString] gets confused by single quotes! *) + +end diff --git a/src/prim.sml b/src/prim.sml new file mode 100644 index 0000000..1de4fc7 --- /dev/null +++ b/src/prim.sml @@ -0,0 +1,119 @@ +(* Copyright (c) 2008, 2014, 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 Prim :> PRIM = struct + +datatype string_mode = Normal | Html + +datatype t = + Int of Int64.int + | Float of Real64.real + | String of string_mode * string + | Char of char + +open Print.PD +open Print + +fun p_t t = + case t of + Int n => string (Int64.toString n) + | Float n => string (Real64.toString n) + | String (_, s) => box [string "\"", string (String.toString s), string "\""] + | Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""] + +fun int2s n = + if Int64.compare (n, Int64.fromInt 0) = LESS then + "-" ^ Int64.toString (Int64.~ n) ^ "LL" + else + Int64.toString n ^ "LL" + +fun int2s' n = + if Int64.compare (n, Int64.fromInt 0) = LESS then + "-" ^ Int64.toString (Int64.~ n) + else + Int64.toString n + +val float2s = String.translate (fn #"~" => "-" | ch => str ch) o Real64.toString + +fun toString t = + case t of + Int n => int2s' n + | Float n => float2s n + | String (_, s) => s + | Char ch => str ch + +fun pad (n, ch, s) = + if size s >= n then + s + else + str ch ^ pad (n-1, ch, s) + +fun quoteDouble ch = + case ch of + #"'" => str ch + | _ => Char.toCString ch + +fun toCChar ch = + case ch of + #"\"" => str ch + | _ => Char.toCString ch + +val toCString = String.translate quoteDouble + +fun p_t_GCC t = + case t of + Int n => string (int2s n) + | Float n => string (float2s n) + | String (_, s) => box [string "\"", string (toCString s), string "\""] + | Char ch => box [string "'", string (toCChar ch), string "'"] + +fun equal x = + case x of + (Int n1, Int n2) => n1 = n2 + | (Float n1, Float n2) => Real64.== (n1, n2) + | (String (_, s1), String (_, s2)) => s1 = s2 + | (Char ch1, Char ch2) => ch1 = ch2 + + | _ => false + +fun compare (p1, p2) = + case (p1, p2) of + (Int n1, Int n2) => Int64.compare (n1, n2) + | (Int _, _) => LESS + | (_, Int _) => GREATER + + | (Float n1, Float n2) => Real64.compare (n1, n2) + | (Float _, _) => LESS + | (_, Float _) => GREATER + + | (String (_, n1), String (_, n2)) => String.compare (n1, n2) + | (String _, _) => LESS + | (_, String _) => GREATER + + | (Char ch1, Char ch2) => Char.compare (ch1, ch2) + +end diff --git a/src/print.sig b/src/print.sig new file mode 100644 index 0000000..7467e04 --- /dev/null +++ b/src/print.sig @@ -0,0 +1,64 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing *) + +signature PRINT = sig + structure PD : PP_DESC + where type PPS.token = string + and type PPS.device = TextIOPP.device + and type PPS.stream = TextIOPP.stream + + type 'a printer = 'a -> PD.pp_desc + + val box : PD.pp_desc list -> PD.pp_desc + val parenIf : bool -> PD.pp_desc -> PD.pp_desc + val space : PD.pp_desc + + val p_list_sep : PD.pp_desc -> 'a printer -> 'a list printer + val p_list : 'a printer -> 'a list printer + + val p_list_sepi : PD.pp_desc -> (int -> 'a printer) -> 'a list printer + + val fprint : PD.PPS.stream -> PD.pp_desc -> unit + val print : PD.pp_desc -> unit + val eprint : PD.pp_desc -> unit + + val fpreface : PD.PPS.stream -> string * PD.pp_desc -> unit + val preface : string * PD.pp_desc -> unit + val epreface : string * PD.pp_desc -> unit + + val fprefaces : PD.PPS.stream -> string -> (string * PD.pp_desc) list -> unit + val prefaces : string -> (string * PD.pp_desc) list -> unit + val eprefaces : string -> (string * PD.pp_desc) list -> unit + + val fprefaces' : PD.PPS.stream -> (string * PD.pp_desc) list -> unit + val prefaces' : (string * PD.pp_desc) list -> unit + val eprefaces' : (string * PD.pp_desc) list -> unit + + val openOut : {dst : TextIO.outstream, wid : int} -> PD.PPS.stream +end diff --git a/src/print.sml b/src/print.sml new file mode 100644 index 0000000..d4059ed --- /dev/null +++ b/src/print.sml @@ -0,0 +1,127 @@ +(* Copyright (c) 2008, 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. + *) + +(* Generic printing support code *) + +structure Print :> PRINT = struct + +structure SM = TextIOPP +structure PD = PPDescFn(SM) + +val openOut = SM.openOut + +type 'a printer = 'a -> PD.pp_desc + +fun box ds = PD.hovBox (PD.PPS.Rel 1, ds) +fun parenIf b d = + if b then + box [PD.string "(", d, PD.string ")"] + else + d +val space = PD.space 1 + +val out = SM.openOut {dst = TextIO.stdOut, wid = 70} +val err = SM.openOut {dst = TextIO.stdErr, wid = 70} + +fun p_list_sep sep f ls = + case ls of + [] => PD.string "" + | [x] => f x + | x :: rest => + let + val tokens = foldr (fn (x, tokens) => + sep :: PD.cut :: f x :: tokens) + [] rest + in + box (f x :: tokens) + end +fun p_list f = p_list_sep (box [PD.string ",", space]) f + +fun p_list_sepi sep f ls = + case ls of + [] => PD.string "" + | [x] => f 0 x + | x :: rest => + let + val tokens = ListUtil.foldri (fn (n, x, tokens) => + sep :: PD.cut :: f (n + 1) x :: tokens) + [] rest + in + box (f 0 x :: tokens) + end + +fun fprint f d = (PD.description (f, d); + PD.PPS.flushStream f) +val print = fprint out +val eprint = fprint err + +fun fpreface f (s, d) = + fprint f (PD.hovBox (PD.PPS.Rel 0, + [PD.string s, PD.space 1, d, PD.newline])) + +val preface = fpreface out +val epreface = fpreface err + +fun fprefaces f s ls = + let + val len = foldl (fn ((s, _), best) => + Int.max (size s, best)) 0 ls + in + fprint f (PD.string s); + fprint f PD.newline; + app (fn (s, d) => + let + val s = CharVector.tabulate (len - size s, + fn _ => #" ") + ^ s ^ ": " + in + fpreface f (s, d) + end) ls + end + +val prefaces = fprefaces out +val eprefaces = fprefaces err + +fun fprefaces' f ls = + let + val len = foldl (fn ((s, _), best) => + Int.max (size s, best)) 0 ls + in + app (fn (s, d) => + let + val s = CharVector.tabulate (len - size s, + fn _ => #" ") + ^ s ^ ": " + in + fpreface f (s, d) + end) ls + end + +val prefaces' = fprefaces' out +val eprefaces' = fprefaces' err + +end diff --git a/src/reduce.sig b/src/reduce.sig new file mode 100644 index 0000000..0a28a59 --- /dev/null +++ b/src/reduce.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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. + *) + +(* Simplify a Core program algebraically *) + +signature REDUCE = sig + + val reduce : Core.file -> Core.file + +end diff --git a/src/reduce.sml b/src/reduce.sml new file mode 100644 index 0000000..04cec16 --- /dev/null +++ b/src/reduce.sml @@ -0,0 +1,953 @@ +(* Copyright (c) 2008-2011, 2013, 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. + *) + +(* Simplify a Core program algebraically *) + +structure Reduce :> REDUCE = struct + +open Core + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +structure E = CoreEnv + +fun multiLiftConInCon n c = + if n = 0 then + c + else + multiLiftConInCon (n - 1) (E.liftConInCon 0 c) + +fun multiLiftExpInExp n e = + if n = 0 then + e + else + multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) + +val count = CoreUtil.Exp.foldB {kind = fn (_, _, c) => c, + con = fn (_, _, c) => c, + exp = fn (x, e, c) => + case e of + ERel x' => if x = x' then c + 1 else c + | _ => c, + bind = fn (x, b) => + case b of + CoreUtil.Exp.RelE _ => x+1 + | _ => x} 0 0 + +val dangling = + CoreUtil.Exp.existsB {kind = fn _ => false, + con = fn _ => false, + exp = fn (n, e) => + case e of + ERel n' => n' >= n + | _ => false, + bind = fn (n, b) => + case b of + CoreUtil.Exp.RelE _ => n + 1 + | _ => n} + +val cdangling = + CoreUtil.Exp.existsB {kind = fn _ => false, + con = fn (n, c) => + case c of + CRel n' => n' >= n + | _ => false, + exp = fn _ => false, + bind = fn (n, b) => + case b of + CoreUtil.Exp.RelC _ => n + 1 + | _ => n} + +datatype env_item = + UnknownK + | KnownK of kind + + | UnknownC + | KnownC of con + + | UnknownE + | KnownE of exp + + | Lift of int * int * int + +val edepth = foldl (fn (UnknownE, n) => n + 1 + | (KnownE _, n) => n + 1 + | (_, n) => n) 0 + +val edepth' = foldl (fn (UnknownE, n) => n + 1 + | (KnownE _, n) => n + 1 + | (Lift (_, _, n'), n) => n + n' + | (_, n) => n) 0 + +val cdepth = foldl (fn (UnknownC, n) => n + 1 + | (KnownC _, n) => n + 1 + | (_, n) => n) 0 + +val cdepth' = foldl (fn (UnknownC, n) => n + 1 + | (KnownC _, n) => n + 1 + | (Lift (_, n', _), n) => n + n' + | (_, n) => n) 0 + +type env = env_item list + +fun ei2s ei = + case ei of + UnknownK => "UK" + | KnownK _ => "KK" + | UnknownC => "UC" + | KnownC _ => "KC" + | UnknownE => "UE" + | KnownE _ => "KE" + | Lift (_, n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")" + +fun e2s env = String.concatWith " " (map ei2s env) + +(*val deKnown = List.filter (fn KnownC _ => false + | KnownE _ => false + | KnownK _ => false + | _ => true)*) + +val deKnown = ListUtil.mapConcat (fn KnownC _ => [] + | KnownE _ => [] + | KnownK _ => [] + | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK) + @ List.tabulate (nc, fn _ => UnknownC) + @ List.tabulate (ne, fn _ => UnknownE) + | x => [x]) + +datatype result = Yes of env | No | Maybe + +fun match (env, p : pat, e : exp) = + let + val baseline = length env + + fun match (env, p, e) = + case (#1 p, #1 e) of + (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env) + + | (PPrim p, EPrim p') => + if Prim.equal (p, p') then + Yes env + else + No + + | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => + if n1 = n2 then + Yes env + else + No + + | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => + if n1 = n2 then + match (env, p, e) + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => + if m1 = m2 andalso con1 = con2 then + Yes env + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => + if m1 = m2 andalso con1 = con2 then + match (env, p, e) + else + No + + | (PRecord xps, ERecord xes) => + if List.exists (fn ((CName _, _), _, _) => false + | _ => true) xes then + Maybe + else + let + fun consider (xps, env) = + case xps of + [] => Yes env + | (x, p, _) :: rest => + case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + NONE => No + | SOME (_, e, _) => + case match (env, p, e) of + No => No + | Maybe => Maybe + | Yes env => consider (rest, env) + in + consider (xps, env) + end + + | _ => Maybe + in + match (env, p, e) + end + +fun returnType m loc = + (TCFun ("a", (KType, loc), + (TFun ((CRel 0, loc), + (CApp (multiLiftConInCon 1 m, (CRel 0, loc)), loc)), loc)), loc) + +fun bindType m loc = + (TCFun ("a", (KType, loc), + (TCFun ("b", (KType, loc), + (TFun ((CApp (multiLiftConInCon 2 m, (CRel 1, loc)), loc), + (TFun ((TFun ((CRel 1, loc), + (CApp (multiLiftConInCon 2 m, (CRel 0, loc)), loc)), + loc), + (CApp (multiLiftConInCon 2 m, (CRel 0, loc)), loc)), loc)), + loc)), loc)), loc) + +fun monadRecord m loc = + (TRecord (CRecord ((KType, loc), + [((CName "Return", loc), + returnType m loc), + ((CName "Bind", loc), + bindType m loc)]), loc), loc) + +fun passive (e : exp) = + case #1 e of + EPrim _ => true + | ERel _ => true + | ENamed _ => true + | ECon (_, _, _, NONE) => true + | ECon (_, _, _, SOME e) => passive e + | EFfi _ => true + | EAbs _ => true + | ECAbs _ => true + | EKAbs _ => true + | ERecord xes => List.all (passive o #2) xes + | EField (e, _, _) => passive e + | _ => false + +fun notFfi (t : con) = + case #1 t of + CFfi _ => false + | _ => true + +fun kindConAndExp (namedC, namedE) = + let + fun kind env (all as (k, loc)) = + case k of + KType => all + | KArrow (k1, k2) => (KArrow (kind env k1, kind env k2), loc) + | KName => all + | KRecord k => (KRecord (kind env k), loc) + | KUnit => all + | KTuple ks => (KTuple (map (kind env) ks), loc) + + | KRel n => + let + fun find (n', env, nudge, lift) = + case env of + [] => raise Fail "Reduce.kind: KRel" + | UnknownC :: rest => find (n', rest, nudge, lift) + | KnownC _ :: rest => find (n', rest, nudge, lift) + | UnknownE :: rest => find (n', rest, nudge, lift) + | KnownE _ :: rest => find (n', rest, nudge, lift) + | Lift (lift', _, _) :: rest => find (n', rest, nudge + lift', lift + lift') + | UnknownK :: rest => + if n' = 0 then + (KRel (n + nudge), loc) + else + find (n' - 1, rest, nudge, lift + 1) + | KnownK k :: rest => + if n' = 0 then + kind (Lift (lift, 0, 0) :: rest) k + else + find (n' - 1, rest, nudge - 1, lift) + in + find (n, env, 0, 0) + end + | KFun (x, k) => (KFun (x, kind (UnknownK :: env) k), loc) + + fun con env (all as (c, loc)) = + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) + case c of + TFun (c1, c2) => (TFun (con env c1, con env c2), loc) + | TCFun (x, k, c2) => (TCFun (x, kind env k, con (UnknownC :: env) c2), loc) + | TKFun (x, c2) => (TKFun (x, con (UnknownK :: env) c2), loc) + | TRecord c => (TRecord (con env c), loc) + + | CRel n => + let + fun find (n', env, nudge, liftK, liftC) = + case env of + [] => raise Fail "Reduce.con: CRel" + | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC) + | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC) + | UnknownE :: rest => find (n', rest, nudge, liftK, liftC) + | KnownE _ :: rest => find (n', rest, nudge, liftK, liftC) + | Lift (liftK', liftC', _) :: rest => find (n', rest, nudge + liftC', + liftK + liftK', liftC + liftC') + | UnknownC :: rest => + if n' = 0 then + (CRel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftK, liftC + 1) + | KnownC c :: rest => + if n' = 0 then + con (Lift (liftK, liftC, 0) :: rest) c + else + find (n' - 1, rest, nudge - 1, liftK, liftC) + in + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0, 0) + end + + | CNamed n => + (case IM.find (namedC, n) of + NONE => all + | SOME c => c) + + | CFfi ("Basis", "monad") => (CAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), monadRecord (CRel 0, loc) loc), loc) + + | CFfi _ => all + | CApp (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case #1 c1 of + CAbs (_, _, b) => + con (KnownC c2 :: deKnown env) b + + | CApp ((CMap (dom, ran), _), f) => + (case #1 c2 of + CRecord (_, []) => (CRecord (kind env ran, []), loc) + | CRecord (_, (x, c) :: rest) => + con (deKnown env) + (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, (CRecord (kind env dom, rest), loc)), loc)), loc) + | _ => (CApp (c1, c2), loc)) + + | _ => (CApp (c1, c2), loc) + end + | CAbs (x, k, b) => (CAbs (x, kind env k, con (UnknownC :: env) b), loc) + + | CKApp (c1, k) => + let + val c1 = con env c1 + in + case #1 c1 of + CKAbs (_, b) => + con (KnownK k :: deKnown env) b + + | _ => (CKApp (c1, kind env k), loc) + end + | CKAbs (x, b) => (CKAbs (x, con (UnknownK :: env) b), loc) + + | CName _ => all + + | CRecord (k, xcs) => (CRecord (kind env k, map (fn (x, c) => (con env x, con env c)) xcs), loc) + | CConcat (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + (CRecord (kind env k, xcs1 @ xcs2), loc) + | (CRecord (_, []), _) => c2 + | (_, CRecord (_, [])) => c1 + | _ => (CConcat (c1, c2), loc) + end + | CMap (dom, ran) => (CMap (kind env dom, kind env ran), loc) + + | CUnit => all + + | CTuple cs => (CTuple (map (con env) cs), loc) + | CProj (c, n) => + let + val c = con env c + in + case #1 c of + CTuple cs => List.nth (cs, n - 1) + | _ => (CProj (c, n), loc) + end) + + fun patCon pc = + case pc of + PConVar _ => pc + | PConFfi {mod = m, datatyp, params, con = c, arg, kind} => + PConFfi {mod = m, datatyp = datatyp, params = params, con = c, + arg = Option.map (con (map (fn _ => UnknownC) params)) arg, + kind = kind} + + + val k = (KType, ErrorMsg.dummySpan) + fun doPart e (this as (x, t), rest) = + ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t), + this :: rest) + + fun exp env (all as (e, loc)) = + let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("env", Print.PD.string (e2s env))]*) + (*val () = if dangling (edepth env) all then + (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("env", Print.PD.string (e2s env))]; + raise Fail "!") + else + ()*) + (*val () = if cdangling (cdepth env) all then + Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("env", Print.PD.string (e2s env))] + else + ()*) + + 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 + + val r = case e of + EPrim _ => all + | ERel n => + let + fun find (n', env, nudge, liftK, liftC, liftE) = + case env of + [] => raise Fail ("Reduce.exp: ERel (" ^ ErrorMsg.spanToString loc ^ ")") + | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC, liftE) + | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC, liftE) + | UnknownC :: rest => find (n', rest, nudge, liftK, liftC + 1, liftE) + | KnownC _ :: rest => find (n', rest, nudge, liftK, liftC, liftE) + | Lift (liftK', liftC', liftE') :: rest => + find (n', rest, nudge + liftE', + liftK + liftK', liftC + liftC', liftE + liftE') + | UnknownE :: rest => + if n' = 0 then + (ERel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftK, liftC, liftE + 1) + | KnownE e :: rest => + if n' = 0 then + ((*print "SUBSTITUTING\n";*) + exp (Lift (liftK, liftC, liftE) :: rest) e) + else + find (n' - 1, rest, nudge - 1, liftK, liftC, liftE) + in + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0, 0, 0) + end + | ENamed n => + (case IM.find (namedE, n) of + NONE => all + | SOME e => e) + | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, + map (con env) cs, Option.map (exp env) eo), loc) + + | EFfi ("Basis", "return") => + (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), + (ECAbs ("a", (KType, loc), + (EAbs ("m", monadRecord (CRel 1, loc) loc, returnType (CRel 1, loc) loc, + (ECApp ((EField ((ERel 0, loc), (CName "Return", loc), + {field = returnType (CRel 1, loc) loc, + rest = (CRecord ((KType, loc), + [((CName "Bind", loc), bindType (CRel 1, loc) loc)]), + loc)}), loc), (CRel 0, loc)), loc)), loc)), loc)), loc) + + | EFfi ("Basis", "bind") => + (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), + (ECAbs ("a", (KType, loc), + (ECAbs ("b", (KType, loc), + (EAbs ("m", monadRecord (CRel 2, loc) loc, bindType (CRel 2, loc) loc, + (ECApp ((ECApp ((EField ((ERel 0, loc), (CName "Bind", loc), + {field = bindType (CRel 2, loc) loc, + rest = (CRecord ((KType, loc), + [((CName "Return", loc), + returnType (CRel 2, loc) loc)]), + loc)}), loc), (CRel 1, loc)), loc), + (CRel 0, loc)), loc)), loc)), loc)), loc)), loc) + + | EFfi ("Basis", "mkMonad") => + (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), + (EAbs ("m", monadRecord (CRel 0, loc) loc, monadRecord (CRel 0, loc) loc, + (ERel 0, loc)), loc)), loc) + + | EFfi ("Basis", "transaction_monad") => + (ERecord [((CName "Return", loc), + (EFfi ("Basis", "transaction_return"), loc), + returnType (CFfi ("Basis", "transaction"), loc) loc), + ((CName "Bind", loc), + (EFfi ("Basis", "transaction_bind"), loc), + bindType (CFfi ("Basis", "transaction"), loc) loc)], loc) + + | EFfi ("Basis", "signal_monad") => + (ERecord [((CName "Return", loc), + (EFfi ("Basis", "signal_return"), loc), + returnType (CFfi ("Basis", "signal"), loc) loc), + ((CName "Bind", loc), + (EFfi ("Basis", "signal_bind"), loc), + bindType (CFfi ("Basis", "signal"), loc) loc)], loc) + + | EFfi _ => all + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) + + (*| EApp ( + (EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (ECase (ed, pes, {disc, ...}), _)), _), + trans2) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + + val pes = map (fn (p, e) => + let + val e' = (EApp (e', e), loc) + val e' = (EApp (e', + multiLiftExpInExp (E.patBindsN p) + trans2), loc) + val e' = exp env e' + in + (p, e') + end) pes + in + (ECase (exp env ed, + pes, + {disc = con env disc, + result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}), + loc) + end*) + + | EApp (e1, e2) => + let + val env' = deKnown env + + val e1 = exp env e1 + val e2 = exp env e2 + in + case #1 e1 of + ELet (x, t, e1', e2') => + (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc) + + | EAbs (x, dom, _, b) => + if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside IS.empty dom then + let + val r = exp (KnownE e2 :: env') b + in + (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b), + ("env", Print.PD.string (e2s env')), + ("e2", CorePrint.p_exp CoreEnv.empty e2), + ("r", CorePrint.p_exp CoreEnv.empty r)];*) + r + end + else + let + val dom = con env' dom + val r = exp (UnknownE :: env') b + in + (*Print.prefaces "El skippo" [("x", Print.PD.string x), + ("e2", CorePrint.p_exp CoreEnv.empty e2)];*) + (ELet (x, dom, e2, r), loc) + end + + | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) => + let + val pes' = map (fn (p, body) => + let + val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env + val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body) + in + (p, body') + end) pes + + val cc' = {disc = con env' disc, result = con env' c2} + in + (ECase (e, pes', cc'), loc) + end + | _ => (EApp (e1, e2), loc) + end + + | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) + + | ECApp (e, c) => + let + val e = exp env e + val c = con env c + in + case #1 e of + ECAbs (_, _, b) => + let + val r = exp (KnownC c :: deKnown env) b + in + (*Print.prefaces "csub" [("l", Print.PD.string (ErrorMsg.spanToString loc)), + ("env", Print.PD.string (e2s (deKnown env))), + ("b", CorePrint.p_exp CoreEnv.empty b), + ("c", CorePrint.p_con CoreEnv.empty c), + ("r", CorePrint.p_exp CoreEnv.empty r)];*) + r + end + | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) => + let + val pes' = map (fn (p, body) => + let + val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env + + val body' = exp env' (ECApp (body, c), #2 body) + in + (p, body') + end) pes + + val c' = E.subConInCon (0, c) c' + val cc' = {disc = con env disc, result = con env c'} + in + (ECase (e, pes', cc'), loc) + end + | _ => (ECApp (e, c), loc) + end + + | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc) + + | EKApp (e, k) => + let + val e = exp env e + in + case #1 e of + EKAbs (_, b) => + let + val r = exp (KnownK k :: deKnown env) b + in + (*Print.prefaces "ksub" [("l", Print.PD.string (ErrorMsg.spanToString loc)), + ("b", CorePrint.p_exp CoreEnv.empty b), + ("k", CorePrint.p_kind CoreEnv.empty k), + ("r", CorePrint.p_exp CoreEnv.empty r)];*) + r + end + | _ => (EKApp (e, kind env k), loc) + end + + | EKAbs (x, e) => (EKAbs (x, exp (UnknownK :: 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, rest}) => + let + val e = exp env e + val c = con env c + + fun default () = (EField (e, c, {field = con env field, rest = con env rest}), 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) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case (#1 e1, #1 e2) of + (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc) + | _ => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + let + val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1 + val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2 + in + exp (deKnown env) (ERecord (xes1 @ xes2), loc) + end + | _ => (EConcat (e1, c1, e2, c2), loc) + end + end + + | ECut (e, c, {field, rest}) => + let + val e = exp env e + val c = con env c + + fun default () = + let + val rest = con env rest + in + case #1 rest of + CRecord (k, xcs) => + let + val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs + in + exp (deKnown env) (ERecord xes, loc) + end + | _ => (ECut (e, c, {field = con env field, rest = rest}), loc) + end + in + case (#1 e, #1 c) of + (ERecord xes, CName x) => + if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then + (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x + | _ => raise Fail "Reduce: ECut") xes), loc) + else + default () + | _ => default () + end + + | ECutMulti (e, c, {rest}) => + let + val e = exp env e + val c = con env c + + fun default () = + let + val rest = con env rest + in + case #1 rest of + CRecord (k, xcs) => + let + val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs + in + exp (deKnown env) (ERecord xes, loc) + end + | _ => (ECutMulti (e, c, {rest = rest}), loc) + end + in + case (#1 e, #1 c) of + (ERecord xes, CRecord (_, xcs)) => + if List.all (fn ((CName _, _), _, _) => true | _ => false) xes + andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then + (ERecord (List.filter (fn ((CName x', _), _, _) => + List.all (fn ((CName x, _), _) => x' <> x + | _ => raise Fail "Reduce: ECutMulti [1]") xcs + | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc) + else + default () + | _ => default () + end + + | ECase (_, [((PRecord [], _), e)], _) => exp env e + + | ECase (e, pes, {disc, result}) => + let + 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 _ => UnknownE) @ env) e)) + pes, {disc = con env disc, result = con env result}), 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) => + let + val e1' = exp env e1 + + val t = con env t + in + if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside IS.empty t) then + exp (KnownE e1 :: env) e2 + else + (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) + end + + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) + in + (*if dangling (edepth' (deKnown env)) r then + (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("r", CorePrint.p_exp CoreEnv.empty r)]; + raise Fail "!!") + else + ();*) + (*if cdangling (cdepth' (deKnown env)) r then + (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("r", CorePrint.p_exp CoreEnv.empty r)]; + raise Fail "!!") + else + ();*) + r + end + in + {kind = kind, con = con, exp = exp} + end + +fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k +fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c +fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e + +fun reduce file = + let + val uses = CoreUtil.File.fold {kind = fn (_, m) => m, + con = fn (_, m) => m, + exp = fn (e, m) => + case e of + ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0)) + | _ => m, + decl = fn (_, m) => m} + IM.empty file + + fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false, + con = fn TCFun _ => true + | TKFun _ => true + | CNamed n => IS.member (names, n) + | _ => false} + + val size = CoreUtil.Exp.fold {kind = fn (_, n) => n, + con = fn (_, n) => n, + exp = fn (_, n) => n + 1} 0 + + fun mayInline (polyC, n, t, e, s) = + let + fun isPolicy t = + case #1 t of + CFfi ("Basis", "sql_policy") => true + | TFun (_, t) => isPolicy t + | _ => false + in + not (Settings.checkNeverInline s) andalso + case IM.find (uses, n) of + NONE => false + | SOME count => count <= 1 + orelse (case #1 e of + ERecord _ => true + | _ => false) + orelse isPolicy t + orelse isPoly polyC t + orelse size e <= Settings.getCoreInline () + end + + fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) = + case #1 d of + DCon (x, n, k, c) => + let + val k = kind namedC [] k + val c = con namedC [] c + in + ((DCon (x, n, k, c), loc), + (if isPoly polyC c then + IS.add (polyC, n) + else + polyC, + IM.insert (namedC, n, c), + namedE)) + end + | DDatatype dts => + ((DDatatype (map (fn (x, n, ps, cs) => + let + val env = map (fn _ => UnknownC) ps + in + (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs) + end) dts), loc), + (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of + NONE => false + | SOME c => isPoly polyC c) cs) + dts then + foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts + else + polyC, + namedC, + namedE)) + | DVal (x, n, t, e, s) => + let + val t = con namedC [] t + val e = exp (namedC, namedE) [] e + in + ((DVal (x, n, t, e, s), loc), + (polyC, + namedC, + if mayInline (polyC, n, t, e, s) then + IM.insert (namedE, n, e) + else + namedE)) + end + | DValRec vis => + ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, + exp (namedC, namedE) [] e, s)) vis), loc), + st) + | DExport _ => (d, st) + | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s', + exp (namedC, namedE) [] pe, + con namedC [] pc, + exp (namedC, namedE) [] ce, + con namedC [] cc), loc), st) + | DSequence _ => (d, st) + | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) + | DDatabase _ => (d, st) + | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) + | DTask (e1, e2) => + let + val e1 = exp (namedC, namedE) [] e1 + val e2 = exp (namedC, namedE) [] e2 + in + ((DTask (e1, e2), loc), + (polyC, + namedC, + namedE)) + end + | DPolicy e1 => + let + val e1 = exp (namedC, namedE) [] e1 + in + ((DPolicy e1, loc), + (polyC, + namedC, + namedE)) + end + | DOnError _ => (d, st) + + val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file + in + file + end + +end diff --git a/src/reduce_local.sig b/src/reduce_local.sig new file mode 100644 index 0000000..ebc22c5 --- /dev/null +++ b/src/reduce_local.sig @@ -0,0 +1,36 @@ +(* 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. + *) + +(* Simplify a Core program algebraically, without unfolding definitions *) + +signature REDUCE_LOCAL = sig + + val reduce : Core.file -> Core.file + val reduceExp : Core.exp -> Core.exp + val reduceCon : Core.con -> Core.con + +end diff --git a/src/reduce_local.sml b/src/reduce_local.sml new file mode 100644 index 0000000..06f49fe --- /dev/null +++ b/src/reduce_local.sml @@ -0,0 +1,386 @@ +(* Copyright (c) 2008-2010, 2013, 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. + *) + +(* Simplify a Core program algebraically, without unfolding definitions *) + +structure ReduceLocal :> REDUCE_LOCAL = struct + +open Core + +structure IM = IntBinaryMap + +fun multiLiftExpInExp n e = + if n = 0 then + e + else + multiLiftExpInExp (n - 1) (CoreEnv.liftExpInExp 0 e) + +datatype env_item = + Unknown + | Known of exp + + | UnknownC + | KnownC of con + + | Lift of int * int + +type env = env_item list + +val deKnown = List.filter (fn Known _ => false + | KnownC _ => false + | _ => true) + +datatype result = Yes of env | No | Maybe + +fun match (env, p : pat, e : exp) = + let + val baseline = length env + + fun match (env, p, e) = + case (#1 p, #1 e) of + (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env) + + | (PPrim p, EPrim p') => + if Prim.equal (p, p') then + Yes env + else + No + + | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => + if n1 = n2 then + Yes env + else + No + + | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => + if n1 = n2 then + match (env, p, e) + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => + if m1 = m2 andalso con1 = con2 then + Yes env + else + No + + | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), + ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => + if m1 = m2 andalso con1 = con2 then + match (env, p, e) + else + No + + | (PRecord xps, ERecord xes) => + if List.exists (fn ((CName _, _), _, _) => false + | _ => true) xes then + Maybe + else + let + fun consider (xps, env) = + case xps of + [] => Yes env + | (x, p, _) :: rest => + case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + NONE => No + | SOME (_, e, _) => + case match (env, p, e) of + No => No + | Maybe => Maybe + | Yes env => consider (rest, env) + in + consider (xps, env) + end + + | _ => Maybe + in + match (env, p, e) + end + +fun con env (all as (c, loc)) = + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) + 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) + | TKFun (x, c2) => (TKFun (x, con env c2), loc) + | TRecord c => (TRecord (con env c), loc) + + | CRel n => + let + fun find (n', env, nudge, liftC) = + case env of + [] => raise Fail "ReduceLocal.con: CRel" + | Unknown :: rest => find (n', rest, nudge, liftC) + | Known _ :: rest => find (n', rest, nudge, liftC) + | Lift (liftC', _) :: rest => find (n', rest, nudge + liftC', + liftC + liftC') + | UnknownC :: rest => + if n' = 0 then + (CRel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftC + 1) + | KnownC c :: rest => + if n' = 0 then + con (Lift (liftC, 0) :: rest) c + else + find (n' - 1, rest, nudge - 1, liftC) + in + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0) + end + | CNamed _ => all + | CFfi _ => all + | CApp (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case #1 c1 of + CAbs (_, _, b) => + con (KnownC c2 :: deKnown env) b + + | CApp ((CMap (dom, ran), _), f) => + (case #1 c2 of + CRecord (_, []) => (CRecord (ran, []), loc) + | CRecord (_, (x, c) :: rest) => + con (deKnown env) + (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc), + (CApp (c1, (CRecord (dom, rest), loc)), loc)), loc) + | _ => (CApp (c1, c2), loc)) + + | _ => (CApp (c1, c2), loc) + end + | CAbs (x, k, b) => (CAbs (x, k, con (UnknownC :: env) b), loc) + + | CKApp (c1, k) => + let + val c1 = con env c1 + in + case #1 c1 of + CKAbs (_, b) => + con (deKnown env) b + + | _ => (CKApp (c1, k), loc) + end + | CKAbs (x, b) => (CKAbs (x, con env b), loc) + + | CName _ => all + + | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (con env x, con env c)) xcs), loc) + | CConcat (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + (CRecord (k, xcs1 @ xcs2), loc) + | (CRecord (_, []), _) => c2 + | (_, CRecord (_, [])) => c1 + | _ => (CConcat (c1, c2), loc) + end + | CMap _ => all + + | CUnit => all + + | CTuple cs => (CTuple (map (con env) cs), loc) + | CProj (c, n) => + let + val c = con env c + in + case #1 c of + CTuple cs => List.nth (cs, n - 1) + | _ => (CProj (c, n), loc) + end) + +fun patCon pc = + case pc of + PConVar _ => pc + | PConFfi {mod = m, datatyp, params, con = c, arg, kind} => + PConFfi {mod = m, datatyp = datatyp, params = params, con = c, + arg = Option.map (con (map (fn _ => UnknownC) params)) arg, + 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) + +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 + in + map doDecl file + end + +val reduceExp = exp [] +val reduceCon = con [] + +end diff --git a/src/rpcify.sig b/src/rpcify.sig new file mode 100644 index 0000000..7da53b7 --- /dev/null +++ b/src/rpcify.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, 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 RPCIFY = sig + + val frob : Core.file -> Core.file + +end diff --git a/src/rpcify.sml b/src/rpcify.sml new file mode 100644 index 0000000..551a151 --- /dev/null +++ b/src/rpcify.sml @@ -0,0 +1,168 @@ +(* Copyright (c) 2009, 2012-2013, 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 Rpcify :> RPCIFY = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +type state = { + exported : IS.set, + export_decls : decl list +} + +fun frob file = + let + val (rpcBaseIds, trpcBaseIds) = + foldl (fn ((d, _), (rpcIds, trpcIds)) => + case d of + DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => + (IS.add (rpcIds, n), trpcIds) + | DVal (_, n, _, (EFfi ("Basis", "tryRpc"), _), _) => + (rpcIds, IS.add (trpcIds, n)) + | DVal (_, n, _, (ENamed n', _), _) => + if IS.member (rpcIds, n') then + (IS.add (rpcIds, n), trpcIds) + else if IS.member (trpcIds, n') then + (rpcIds, IS.add (trpcIds, n)) + else + (rpcIds, trpcIds) + | _ => (rpcIds, trpcIds)) + (IS.empty, IS.empty) file + + val tfuncs = foldl + (fn ((d, _), tfuncs) => + let + fun doOne ((x, n, t, e, _), tfuncs) = + let + val loc = #2 e + + fun crawl (t, e, args) = + case (#1 t, #1 e) of + (CApp (_, ran), _) => + SOME (x, rev args, ran, e) + | (TFun (arg, rest), EAbs (x, _, _, e)) => + crawl (rest, e, (x, arg) :: args) + | (TFun (arg, rest), _) => + crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args) + | _ => NONE + in + case crawl (t, e, []) of + NONE => tfuncs + | SOME sg => IM.insert (tfuncs, n, sg) + end + in + case d of + DVal vi => doOne (vi, tfuncs) + | DValRec vis => foldl doOne tfuncs vis + | _ => tfuncs + end) + IM.empty file + + fun exp (e, st) = + let + fun getApp (e', args) = + case e' of + ENamed n => SOME (n, args) + | EApp (e1, e2) => getApp (#1 e1, e2 :: args) + | _ => NONE + + fun newRpc (trans : exp, st : state, fm) = + case getApp (#1 trans, []) of + NONE => (ErrorMsg.errorAt (#2 trans) + "RPC code doesn't use a named function or transaction"; + (*Print.preface ("Expression", + CorePrint.p_exp CoreEnv.empty trans);*) + (#1 trans, st)) + | SOME (n, args) => + case IM.find (tfuncs, n) of + NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*) + raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n)) + | SOME (_, _, ran, _) => + let + val loc = #2 trans + + val (exported, export_decls) = + if IS.member (#exported st, n) then + (#exported st, #export_decls st) + else + (IS.add (#exported st, n), + (DExport (Rpc ReadWrite, n, false), loc) :: #export_decls st) + + val st = {exported = exported, + export_decls = export_decls} + + val e' = EServerCall (n, args, ran, fm) + in + (e', st) + end + in + case e of + EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st, None) + | EApp ((ECApp ((EFfi ("Basis", "tryRpc"), _), ran), _), trans) => newRpc (trans, st, Error) + | EApp ((ECApp ((ENamed n, _), ran), _), trans) => + if IS.member (rpcBaseIds, n) then + newRpc (trans, st, None) + else if IS.member (trpcBaseIds, n) then + newRpc (trans, st, Error) + else + (e, st) + + | _ => (e, st) + end + + and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, + con = fn x => x, + exp = exp} st (ReduceLocal.reduceExp e) + + fun decl (d, st : state) = + let + val (d, st) = U.Decl.foldMap {kind = fn x => x, + con = fn x => x, + exp = exp, + decl = fn x => x} + st d + in + (d :: #export_decls st, + {exported = #exported st, + export_decls = []}) + end + + val (file, _) = ListUtil.foldlMapConcat decl + {exported = IS.empty, + export_decls = []} + file + in + file + end + +end diff --git a/src/scriptcheck.sig b/src/scriptcheck.sig new file mode 100644 index 0000000..afb557b --- /dev/null +++ b/src/scriptcheck.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2009, 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 SCRIPT_CHECK = sig + + val classify : Mono.file -> Mono.file + +end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml new file mode 100644 index 0000000..0d30ebc --- /dev/null +++ b/src/scriptcheck.sml @@ -0,0 +1,182 @@ +(* Copyright (c) 2009, 2014, 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 ScriptCheck :> SCRIPT_CHECK = struct + +open Mono + +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) +structure IS = IntBinarySet + +val pushBasis = SS.addList (SS.empty, + ["new_channel", + "self"]) + +datatype rpcmap = + Rpc of int (* ID of function definition *) + | Module of rpcmap SM.map + +fun lookup (r : rpcmap, k : string) = + let + fun lookup' (r, ks) = + case r of + Rpc x => SOME x + | Module m => + case ks of + [] => NONE + | k :: ks' => + case SM.find (m, k) of + NONE => NONE + | SOME r' => lookup' (r', ks') + in + lookup' (r, String.tokens (fn ch => ch = #"/") k) + end + +fun insert (r : rpcmap, k : string, v) = + let + fun insert' (r, ks) = + case r of + Rpc _ => Rpc v + | Module m => + case ks of + [] => Rpc v + | k :: ks' => + let + val r' = case SM.find (m, k) of + NONE => Module SM.empty + | SOME r' => r' + in + Module (SM.insert (m, k, insert' (r', ks'))) + end + in + insert' (r, String.tokens (fn ch => ch = #"/") k) + end + +fun dump (r : rpcmap) = + case r of + Rpc _ => print "ROOT\n" + | Module m => (print "<Module>\n"; + SM.appi (fn (k, r') => (print (k ^ ":\n"); + dump r')) m; + print "</Module>\n") + +fun classify (ds, ps) = + let + val proto = Settings.currentProtocol () + + fun inString {needle, haystack} = String.isSubstring needle haystack + + fun hasClient {basis, rpcs, funcs, push} = + MonoUtil.Exp.exists {typ = fn _ => false, + exp = fn ERecv _ => push + | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | EJavaScript _ => not push + | ENamed n => IS.member (funcs, n) + | EServerCall (e, _, _, _) => + let + fun head (e : exp) = + case #1 e of + EStrcat (e1, _) => head e1 + | EPrim (Prim.String (_, s)) => SOME s + | _ => NONE + in + case head e of + NONE => true + | SOME fcall => + case lookup (rpcs, fcall) of + NONE => true + | SOME n => IS.member (funcs, n) + end + | _ => false} + + fun decl ((d, _), rpcs) = + case d of + DExport (Mono.Rpc _, fcall, n, _, _, _) => + insert (rpcs, fcall, n) + | _ => rpcs + + val rpcs = foldl decl (Module SM.empty) ds + + fun decl ((d, _), (pull_ids, push_ids)) = + let + val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false} + val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true} + in + case d of + DVal (_, n, _, e, _) => (if hasClientPull e then + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) + | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then + foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) + pull_ids xes + else + pull_ids, + if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then + foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) + push_ids xes + else + push_ids) + | _ => (pull_ids, push_ids) + end + + val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds + + val foundBad = ref false + + val all_ids = IS.union (pull_ids, push_ids) + + val ps = map (fn n => + (n, if IS.member (push_ids, n) then + (if not (#persistent proto) andalso not (!foundBad) then + (foundBad := true; + ErrorMsg.error ("This program needs server push, but the current protocol (" + ^ #name proto ^ ") doesn't support that.")) + else + (); + ServerAndPullAndPush) + else if IS.member (pull_ids, n) then + ServerAndPull + else + ServerOnly, AnyDb)) (IS.listItems all_ids) + in + (ds, ps) + end + +end + diff --git a/src/search.sig b/src/search.sig new file mode 100644 index 0000000..ac86714 --- /dev/null +++ b/src/search.sig @@ -0,0 +1,62 @@ +(* Copyright (c) 2008, 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 SEARCH = sig + + datatype ('state, 'abort) result = + Return of 'abort + | Continue of 'state + + type ('data, 'state, 'abort) mapfolder = + 'data -> 'state -> ('data * 'state, 'abort) result + + type ('context, 'data, 'state, 'abort) mapfolderB = + 'context -> 'data -> 'state -> ('data * 'state, 'abort) result + + val return2 : 'data -> 'state -> ('data * 'state, 'abort) result + + val map : ('state1, 'abort) result + * ('state1 -> 'state2) + -> ('state2, 'abort) result + + val map2 : ('state2 -> ('state1 * 'state2, 'abort) result) + * ('state1 -> 'state1') + -> ('state2 -> ('state1' * 'state2, 'abort) result) + + val bind : ('state1, 'abort) result + * ('state1 -> ('state2, 'abort) result) + -> ('state2, 'abort) result + + val bind2 : ('state2 -> ('state1 * 'state2, 'abort) result) + * ('state1 -> 'state2 -> ('state1' * 'state2, 'abort) result) + -> ('state2 -> ('state1' * 'state2, 'abort) result) + + val bindP : (('state11 * 'state12) * 'state2, 'abort) result + * ('state11 -> 'state2 -> ('state11 * 'state2, 'abort) result) + -> (('state11 * 'state12) * 'state2, 'abort) result + +end diff --git a/src/search.sml b/src/search.sml new file mode 100644 index 0000000..563496f --- /dev/null +++ b/src/search.sml @@ -0,0 +1,73 @@ +(* Copyright (c) 2008, 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 Search :> SEARCH = struct + +datatype ('state, 'abort) result = + Return of 'abort + | Continue of 'state + +type ('data, 'state, 'abort) mapfold_arg = + 'data * 'state -> ('data * 'state, 'abort) result + +type ('data, 'state, 'abort) mapfolder = + 'data -> 'state -> ('data * 'state, 'abort) result + +type ('context, 'data, 'state, 'abort) mapfolderB = + 'context -> 'data -> 'state -> ('data * 'state, 'abort) result + +fun return2 v acc = Continue (v, acc) + +fun map (r, f) = + case r of + Continue acc => Continue (f acc) + | Return x => Return x + +fun map2 (r, f) acc = + case r acc of + Continue (x, acc) => Continue (f x, acc) + | Return x => Return x + +fun bind (r, f) = + case r of + Continue acc => f acc + | Return x => Return x + +fun bind2 (r, f) acc = + case r acc of + Continue (x, acc) => f x acc + | Return x => Return x + +fun bindP (r, f) = + case r of + Continue ((x, pos), acc) => + map (f x acc, + fn (x', acc') => + ((x', pos), acc')) + | Return x => Return x + +end diff --git a/src/settings.sig b/src/settings.sig new file mode 100644 index 0000000..256a12b --- /dev/null +++ b/src/settings.sig @@ -0,0 +1,309 @@ +(* Copyright (c) 2008-2011, 2013, 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 SETTINGS = sig + + (* Call this when compiling a new project, e.g. with the Ur/Web daemon or from the SML/NJ REPL. + * Some settings stay, but most are reset, especially files cached for the app to serve. *) + val reset : unit -> unit + + (* XXX these should be unit -> string too *) + val configBin : string ref + val configLib : string ref + val configSrcLib : string ref + val configInclude : string ref + val configSitelisp : string ref + + val libUr : unit -> string + val libC : unit -> string + val libJs : unit -> string + + val setDebug : bool -> unit + val getDebug : unit -> bool + + val libFile : string -> string + val clibFile : string -> string + + (* How do all application URLs begin? *) + val setUrlPrefix : string -> unit + val getUrlPrefix : unit -> string + val getUrlPrePrefix : unit -> string + val getUrlPrefixFull : unit -> string + (* The full prefix is the value that was set explicitly, while the "pre" + * prefix gets the protocol/host/port part and the unqualified prefix gets + * the URI. *) + + (* How many seconds should the server wait before assuming a Comet client has left? *) + val setTimeout : int -> unit + val getTimeout : unit -> int + + (* Which C header files are needed? *) + val setHeaders : string list -> unit + val getHeaders : unit -> string list + + (* Which extra JavaScript URLs should be included? *) + val setScripts : string list -> unit + val getScripts : unit -> string list + + type ffi = string * string + + (* Which FFI types may be sent from clients to servers? *) + val setClientToServer : ffi list -> unit + val mayClientToServer : ffi -> bool + + (* Which FFI functions have side effects? *) + val setEffectful : ffi list -> unit + val addEffectful : ffi -> unit + val isEffectful : ffi -> bool + + (* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *) + val setBenignEffectful : ffi list -> unit + val addBenignEffectful : ffi -> unit + val isBenignEffectful : ffi -> bool + + (* Which FFI functions may only be run in clients? *) + val setClientOnly : ffi list -> unit + val addClientOnly : ffi -> unit + val isClientOnly : ffi -> bool + + (* Which FFI functions may only be run on servers? *) + val setServerOnly : ffi list -> unit + val addServerOnly : ffi -> unit + val isServerOnly : ffi -> bool + + (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) + val setJsModule : string option -> unit + val setJsFuncs : (ffi * string) list -> unit + val addJsFunc : ffi * string -> unit + val jsFunc : ffi -> string option + val allJsFuncs : unit -> (ffi * string) list + + datatype pattern_kind = Exact | Prefix + datatype action = Allow | Deny + type rule = { action : action, kind : pattern_kind, pattern : string } + + datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style + type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } + + (* Rules for rewriting URLs from canonical forms *) + val setRewriteRules : rewrite list -> unit + val rewrite : path_kind -> string -> string + + (* Validating URLs and MIME types *) + val setUrlRules : rule list -> unit + val getUrlRules : unit -> rule list + val checkUrl : string -> bool + + val setMimeRules : rule list -> unit + val getMimeRules : unit -> rule list + val checkMime : string -> bool + + val setRequestHeaderRules : rule list -> unit + val getRequestHeaderRules : unit -> rule list + val checkRequestHeader : string -> bool + + val setResponseHeaderRules : rule list -> unit + val getResponseHeaderRules : unit -> rule list + val checkResponseHeader : string -> bool + + val setEnvVarRules : rule list -> unit + val getEnvVarRules : unit -> rule list + val checkEnvVar : string -> bool + + val setMetaRules : rule list -> unit + val getMetaRules : unit -> rule list + val checkMeta : string -> bool + + (* Web protocols that generated programs may speak *) + type protocol = { + name : string, (* Call it this on the command line *) + compile : string, (* Pass these `gcc -c' arguments *) + linkStatic : string, (* Pass these static linker arguments *) + linkDynamic : string,(* Pass these dynamic linker arguments *) + persistent : bool, (* Multiple requests per process? *) + code : unit -> Print.PD.pp_desc (* Extra code to include in C files *) + } + val addProtocol : protocol -> unit + val setProtocol : string -> unit + val currentProtocol : unit -> protocol + + (* Different DBMSes *) + datatype sql_type = + Int + | Float + | String + | Char + | Bool + | Time + | Blob + | Channel + | Client + | Nullable of sql_type + + val p_sql_ctype : sql_type -> string + val isBlob : sql_type -> bool + val isNotNull : sql_type -> bool + + datatype failure_mode = Error | None + + type dbms = { + name : string, + (* Call it this on the command line *) + randomFunction : string, + (* DBMS's name for random number-generating function *) + header : string, + (* Include this C header file *) + link : string, + (* Pass these linker arguments *) + p_sql_type : sql_type -> string, + init : {dbstring : string, + prepared : (string * int) list, + tables : (string * (string * sql_type) list) list, + views : (string * (string * sql_type) list) list, + sequences : string list} -> Print.PD.pp_desc, + (* Define uw_client_init(), uw_db_init(), uw_db_close(), uw_db_begin(), uw_db_commit(), and uw_db_rollback() *) + query : {loc : ErrorMsg.span, cols : sql_type list, + doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) + -> Print.PD.pp_desc} + -> Print.PD.pp_desc, + queryPrepared : {loc : ErrorMsg.span, id : int, query : string, + inputs : sql_type list, cols : sql_type list, + doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, + typ : sql_type} -> Print.PD.pp_desc) + -> Print.PD.pp_desc, + nested : bool} + -> Print.PD.pp_desc, + dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc, + dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, + inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc, + nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> Print.PD.pp_desc, + nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, + setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, + sqlifyString : string -> string, + p_cast : string * sql_type -> string, + p_blank : int * sql_type -> string (* Prepared statement input *), + supportsDeleteAs : bool, + supportsUpdateAs : bool, + createSequence : string -> string, + textKeysNeedLengths : bool, + supportsNextval : bool, + supportsNestedPrepared : bool, + sqlPrefix : string, + supportsOctetLength : bool, + trueString : string, + falseString : string, + onlyUnion : bool, + nestedRelops : bool, + windowFunctions : bool, + supportsIsDistinctFrom : bool + } + + val addDbms : dbms -> unit + val setDbms : string -> unit + val currentDbms : unit -> dbms + + val setDbstring : string option -> unit + val getDbstring : unit -> string option + + val setExe : string option -> unit + val getExe : unit -> string option + + val setSql : string option -> unit + val getSql : unit -> string option + + val setCoreInline : int -> unit + val getCoreInline : unit -> int + + val setMonoInline : int -> unit + val getMonoInline : unit -> int + + val setStaticLinking : bool -> unit + val getStaticLinking : unit -> bool + + val setBootLinking : bool -> unit + val getBootLinking : unit -> bool + + val setDeadlines : bool -> unit + val getDeadlines : unit -> bool + + val setSigFile : string option -> unit + val getSigFile : unit -> string option + + (* Which GET-able functions should be allowed to have side effects? *) + val setSafeGets : string list -> unit + val isSafeGet : string -> bool + + val setOnError : (string * string list * string) option -> unit + val getOnError : unit -> (string * string list * string) option + + val addLimit : string * int -> unit + val limits : unit -> (string * int) list + + val setMinHeap : int -> unit + val getMinHeap : unit -> int + + val addAlwaysInline : string -> unit + val checkAlwaysInline : string -> bool + + val addNeverInline : string -> unit + val checkNeverInline : string -> bool + + val addNoXsrfProtection : string -> unit + val checkNoXsrfProtection : string -> bool + + val setTimeFormat : string -> unit + val getTimeFormat : unit -> string + + val getCCompiler : unit -> string + val setCCompiler : string -> unit + + val setMangleSql : bool -> unit + val mangleSql : string -> string + val mangleSqlCatalog : string -> string + val mangleSqlTable : string -> string + + val setIsHtml5 : bool -> unit + val getIsHtml5 : unit -> bool + + val setLessSafeFfi : bool -> unit + val getLessSafeFfi : unit -> bool + + val setSqlcache : bool -> unit + val getSqlcache : unit -> bool + + val setFilePath : string -> unit + (* Sets the directory where we look for files being added below. *) + + val addFile : {Uri : string, LoadFromFilename : string} -> unit + val listFiles : unit -> {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector} list + + val addJsFile : string (* filename *) -> unit + val listJsFiles : unit -> {Filename : string, Content : string} list + + val setOutputJsFile : string option (* filename *) -> unit + val getOutputJsFile : unit -> string option +end diff --git a/src/settings.sml b/src/settings.sml new file mode 100644 index 0000000..a3263c0 --- /dev/null +++ b/src/settings.sml @@ -0,0 +1,1012 @@ +(* Copyright (c) 2008-2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Settings :> SETTINGS = struct + +val configBin = ref Config.bin +val configLib = ref Config.lib +val configSrcLib = ref Config.srclib +val configInclude = ref Config.includ +val configSitelisp = ref Config.sitelisp + +val configCCompiler = ref Config.ccompiler + +fun getCCompiler () = !configCCompiler +fun setCCompiler cc = configCCompiler := cc + +fun libUr () = OS.Path.joinDirFile {dir = !configSrcLib, + file = "ur"} +fun libC () = OS.Path.joinDirFile {dir = !configSrcLib, + file = "c"} +fun libJs () = OS.Path.joinDirFile {dir = !configSrcLib, + file = "js"} + +fun libFile s = OS.Path.joinDirFile {dir = libUr (), + file = s} + +val urlPrefixFull = ref "/" +val urlPrefix = ref "/" +val urlPrePrefix = ref "" +val timeout = ref 0 +val headers = ref ([] : string list) +val scripts = ref ([] : string list) + +fun getUrlPrefixFull () = !urlPrefixFull +fun getUrlPrefix () = !urlPrefix +fun getUrlPrePrefix () = !urlPrePrefix +fun setUrlPrefix p = + let + val prefix = if p = "" then + "/" + else if String.sub (p, size p - 1) <> #"/" then + p ^ "/" + else + p + + fun findPrefix n = + let + val (befor, after) = Substring.splitl (fn ch => ch <> #"/") (Substring.extract (prefix, n, NONE)) + in + if Substring.isEmpty after then + ("", prefix) + else + (String.substring (prefix, 0, n) ^ Substring.string befor, Substring.string after) + end + + val (prepre, prefix) = + if String.isPrefix "http://" prefix then + findPrefix 7 + else if String.isPrefix "https://" prefix then + findPrefix 8 + else + ("", prefix) + in + urlPrefixFull := p; + urlPrePrefix := prepre; + urlPrefix := prefix + end + +fun getTimeout () = !timeout +fun setTimeout n = timeout := n + +fun getHeaders () = !headers +fun setHeaders ls = headers := ls + +fun getScripts () = !scripts +fun setScripts ls = scripts := ls + +type ffi = string * string + +structure K = struct +type ord_key = ffi +fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) +end + +structure S = BinarySetFn(K) +structure M = BinaryMapFn(K) + +fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x) + +val clientToServerBase = basis ["int", + "float", + "string", + "time", + "file", + "unit", + "option", + "list", + "bool", + "variant"] +val clientToServer = ref clientToServerBase +fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls) +fun mayClientToServer x = S.member (!clientToServer, x) + +val effectfulBase = basis ["dml", + "nextval", + "setval", + "set_cookie", + "clear_cookie", + "new_channel", + "send", + "htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "urlifyChannel_w"] + +val effectful = ref effectfulBase +fun setEffectful ls = effectful := S.addList (effectfulBase, ls) +fun isEffectful ("Sqlcache", _) = true + | isEffectful x = S.member (!effectful, x) +fun addEffectful x = effectful := S.add (!effectful, x) + +val benignBase = basis ["get_cookie", + "new_client_source", + "get_client_source", + "set_client_source", + "current", + "alert", + "confirm", + "onError", + "onFail", + "onConnectFail", + "onDisconnect", + "onServerError", + "mouseEvent", + "keyEvent", + "debug", + "rand", + "now", + "getHeader", + "setHeader", + "spawn", + "onClick", + "onDblclick", + "onContextmenu", + "onKeydown", + "onKeypress", + "onKeyup", + "onMousedown", + "onMouseenter", + "onMouseleave", + "onMousemove", + "onMouseout", + "onMouseover", + "onMouseup", + "preventDefault", + "stopPropagation", + "fresh", + "giveFocus", + "currentUrlHasPost", + "currentUrlHasQueryString", + "currentUrl"] + +val benign = ref benignBase +fun setBenignEffectful ls = benign := S.addList (benignBase, ls) +fun addBenignEffectful x = benign := S.add (!benign, x) +fun isBenignEffectful x = S.member (!benign, x) + +val clientBase = basis ["get_client_source", + "current", + "alert", + "confirm", + "recv", + "sleep", + "spawn", + "onError", + "onFail", + "onConnectFail", + "onDisconnect", + "onServerError", + "mouseEvent", + "keyEvent", + "onClick", + "onContextmenu", + "onDblclick", + "onKeydown", + "onKeypress", + "onKeyup", + "onMousedown", + "onMouseenter", + "onMouseleave", + "onMousemove", + "onMouseout", + "onMouseover", + "onMouseup", + "preventDefault", + "stopPropagation", + "giveFocus"] +val client = ref clientBase +fun setClientOnly ls = client := S.addList (clientBase, ls) +fun addClientOnly x = client := S.add (!client, x) +fun isClientOnly x = S.member (!client, x) + +val serverBase = basis ["requestHeader", + "query", + "dml", + "nextval", + "setval", + "channel", + "send", + "fieldName", + "fieldValue", + "remainingFields", + "firstFormField"] +val server = ref serverBase +fun setServerOnly ls = server := S.addList (serverBase, ls) +fun addServerOnly x = server := S.add (!server, x) +fun isServerOnly x = S.member (!server, x) + +val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty + +val jsFuncsBase = basisM [("alert", "alert"), + ("stringToTime", "stringToTime"), + ("stringToTime_error", "stringToTime_error"), + ("timef", "strftime"), + ("confirm", "confrm"), + ("get_client_source", "sg"), + ("current", "scur"), + ("htmlifyBool", "bs"), + ("htmlifyFloat", "ts"), + ("htmlifyInt", "ts"), + ("htmlifyString", "eh"), + ("new_client_source", "sc"), + ("set_client_source", "sv"), + ("stringToFloat", "pflo"), + ("stringToInt", "pio"), + ("stringToFloat_error", "pfl"), + ("stringToInt_error", "pi"), + ("urlifyInt", "ts"), + ("urlifyFloat", "ts"), + ("urlifyTime", "ts"), + ("urlifyString", "uf"), + ("urlifyBool", "ub"), + ("recv", "rv"), + ("strcat", "cat"), + ("intToString", "ts"), + ("floatToString", "ts"), + ("charToString", "ts"), + ("onError", "onError"), + ("onFail", "onFail"), + ("onConnectFail", "onConnectFail"), + ("onDisconnect", "onDisconnect"), + ("onServerError", "onServerError"), + ("attrifyString", "atr"), + ("attrifyInt", "ts"), + ("attrifyFloat", "ts"), + ("attrifyBool", "bs"), + ("boolToString", "bs"), + ("str1", "id"), + ("strsub", "sub"), + ("strsuffix", "suf"), + ("strlen", "slen"), + ("strindex", "sidx"), + ("strsindex", "ssidx"), + ("strchr", "schr"), + ("substring", "ssub"), + ("strcspn", "sspn"), + ("strlenGe", "strlenGe"), + ("mouseEvent", "uw_mouseEvent"), + ("keyEvent", "uw_keyEvent"), + ("minTime", "0"), + ("stringToBool_error", "s2be"), + ("stringToBool", "s2b"), + + ("islower", "isLower"), + ("isupper", "isUpper"), + ("isalpha", "isAlpha"), + ("isdigit", "isDigit"), + ("isalnum", "isAlnum"), + ("isblank", "isBlank"), + ("isspace", "isSpace"), + ("isxdigit", "isXdigit"), + ("isprint", "isPrint"), + ("tolower", "toLower"), + ("toupper", "toUpper"), + ("ord", "ord"), + + ("checkUrl", "checkUrl"), + ("bless", "bless"), + ("blessData", "blessData"), + + ("eq_time", "eq"), + ("lt_time", "lt"), + ("le_time", "le"), + + ("debug", "uw_debug"), + ("naughtyDebug", "uw_debug"), + + ("floatFromInt", "float"), + ("ceil", "ceil"), + ("trunc", "trunc"), + ("round", "round"), + ("floor", "floor"), + + ("pow", "pow"), + ("sqrt", "sqrt"), + ("sin", "sin"), + ("cos", "cos"), + ("log", "log"), + ("exp", "exp"), + ("asin", "asin"), + ("acos", "acos"), + ("atan", "atan"), + ("atan2", "atan2"), + ("abs", "abs"), + + ("now", "now"), + ("timeToString", "showTime"), + ("htmlifyTime", "showTimeHtml"), + ("toSeconds", "toSeconds"), + ("addSeconds", "addSeconds"), + ("diffInSeconds", "diffInSeconds"), + ("toMilliseconds", "toMilliseconds"), + ("fromMilliseconds", "fromMilliseconds"), + ("diffInMilliseconds", "diffInMilliseconds"), + + ("fromDatetime", "fromDatetime"), + ("datetimeYear", "datetimeYear"), + ("datetimeMonth", "datetimeMonth"), + ("datetimeDay", "datetimeDay"), + ("datetimeHour", "datetimeHour"), + ("datetimeMinute", "datetimeMinute"), + ("datetimeSecond", "datetimeSecond"), + ("datetimeDayOfWeek", "datetimeDayOfWeek"), + + + ("onClick", "uw_onClick"), + ("onContextmenu", "uw_onContextmenu"), + ("onDblclick", "uw_onDblclick"), + ("onKeydown", "uw_onKeydown"), + ("onKeypress", "uw_onKeypress"), + ("onKeyup", "uw_onKeyup"), + ("onMousedown", "uw_onMousedown"), + ("onMouseenter", "uw_onMouseenter"), + ("onMouseleave", "uw_onMouseleave"), + ("onMousemove", "uw_onMousemove"), + ("onMouseout", "uw_onMouseout"), + ("onMouseover", "uw_onMouseover"), + ("onMouseup", "uw_onMouseup"), + ("preventDefault", "uw_preventDefault"), + ("stopPropagation", "uw_stopPropagation"), + + ("fresh", "fresh"), + + ("atom", "atom"), + ("css_url", "css_url"), + ("property", "property"), + ("giveFocus", "giveFocus"), + + ("htmlifySpecialChar", "htmlifySpecialChar"), + ("chr", "chr")] +val jsFuncs = ref jsFuncsBase +val jsModule = ref (NONE : string option) +fun setJsModule m = jsModule := m +fun jsFuncName f = + case !jsModule of + SOME m => m ^ "." ^ f + | NONE => f +fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls +fun jsFunc x = M.find (!jsFuncs, x) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v) +fun allJsFuncs () = M.listItemsi (!jsFuncs) + +datatype pattern_kind = Exact | Prefix +datatype action = Allow | Deny +type rule = { action : action, kind : pattern_kind, pattern : string } + +datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style +type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } + +fun pak2s pak = + case pak of + Exact => "Exact" + | Prefix => "Prefix" +fun pk2s pk = + case pk of + Any => "Any" + | Url => "Url" + | Table => "Table" + | Sequence => "Sequence" + | View => "View" + | Relation => "Relation" + | Cookie => "Cookie" + | Style => "Style" +fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">" + +val rewrites = ref ([] : rewrite list) + +fun subsume (pk1, pk2) = + pk1 = pk2 + orelse pk2 = Any + orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View) + +fun setRewriteRules ls = rewrites := ls +fun rewrite pk s = + let + fun rew (ls : rewrite list) = + case ls of + [] => s + | rewr :: ls => + let + fun match () = + case #kind rewr of + Exact => if #from rewr = s then + SOME (size s) + else + NONE + | Prefix => if String.isPrefix (#from rewr) s then + SOME (size (#from rewr)) + else + NONE + in + if subsume (pk, #pkind rewr) then + case match () of + NONE => rew ls + | SOME suffixStart => + let + val s = #to rewr ^ String.extract (s, suffixStart, NONE) + in + if #hyphenate rewr then + String.translate (fn #"_" => "-" | ch => str ch) s + else + s + end + else + rew ls + end + in + rew (!rewrites) + end + +val url = ref ([] : rule list) +val mime = ref ([] : rule list) +val request = ref ([] : rule list) +val response = ref ([] : rule list) +val env = ref ([] : rule list) +val meta = ref ([] : rule list) + +fun setUrlRules ls = url := ls +fun setMimeRules ls = mime := ls +fun setRequestHeaderRules ls = request := ls +fun setResponseHeaderRules ls = response := ls +fun setEnvVarRules ls = env := ls +fun setMetaRules ls = meta := ls + +fun getUrlRules () = !url +fun getMimeRules () = !mime +fun getRequestHeaderRules () = !request +fun getResponseHeaderRules () = !response +fun getEnvVarRules () = !env +fun getMetaRules () = !meta + +fun check f rules s = + let + fun chk (ls : rule list) = + case ls of + [] => false + | rule :: ls => + let + val matches = + case #kind rule of + Exact => #pattern rule = s + | Prefix => String.isPrefix (#pattern rule) s + in + if matches then + case #action rule of + Allow => true + | Deny => false + else + chk ls + end + in + f s andalso chk (!rules) + end + +val checkUrl = check (fn _ => true) url + +val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+") +val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".") +val validMeta = CharVector.all (fn ch => Char.isAlpha ch orelse ch = #"-") + +val checkMime = check validMime mime +val checkRequestHeader = check validMime request +val checkResponseHeader = check validMime response +val checkEnvVar = check validEnv env +val checkMeta = check validMeta meta + + +type protocol = { + name : string, + compile : string, + linkStatic : string, + linkDynamic : string, + persistent : bool, + code : unit -> Print.PD.pp_desc +} +val protocols = ref ([] : protocol list) +fun addProtocol p = protocols := p :: !protocols +fun getProtocol s = List.find (fn p => #name p = s) (!protocols) + +fun clibFile s = OS.Path.joinDirFile {dir = libC (), + file = s} + +val curProto = ref {name = "", + compile = "", + linkStatic = "", + linkDynamic = "", + persistent = false, + code = fn () => Print.box []} +fun setProtocol name = + case getProtocol name of + NONE => raise Fail ("Unknown protocol " ^ name) + | SOME p => curProto := p +fun currentProtocol () = !curProto + +val debug = ref false +fun setDebug b = debug := b +fun getDebug () = !debug + +datatype sql_type = + Int + | Float + | String + | Char + | Bool + | Time + | Blob + | Channel + | Client + | Nullable of sql_type + +fun p_sql_ctype t = + let + open Print.PD + open Print + in + case t of + Int => "uw_Basis_int" + | Float => "uw_Basis_float" + | String => "uw_Basis_string" + | Char => "uw_Basis_char" + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time" + | Blob => "uw_Basis_blob" + | Channel => "uw_Basis_channel" + | Client => "uw_Basis_client" + | Nullable String => "uw_Basis_string" + | Nullable t => p_sql_ctype t ^ "*" + end + +fun isBlob Blob = true + | isBlob (Nullable t) = isBlob t + | isBlob _ = false + +fun isNotNull (Nullable _) = false + | isNotNull _ = true + +datatype failure_mode = Error | None + +type dbms = { + name : string, + randomFunction : string, + header : string, + link : string, + p_sql_type : sql_type -> string, + init : {dbstring : string, + prepared : (string * int) list, + tables : (string * (string * sql_type) list) list, + views : (string * (string * sql_type) list) list, + sequences : string list} -> Print.PD.pp_desc, + query : {loc : ErrorMsg.span, cols : sql_type list, + doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, typ : sql_type} -> Print.PD.pp_desc) + -> Print.PD.pp_desc} + -> Print.PD.pp_desc, + queryPrepared : {loc : ErrorMsg.span, id : int, query : string, + inputs : sql_type list, cols : sql_type list, + doCols : ({loc : ErrorMsg.span, wontLeakStrings : bool, col : int, + typ : sql_type} -> Print.PD.pp_desc) + -> Print.PD.pp_desc, + nested : bool} + -> Print.PD.pp_desc, + dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc, + dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, + inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc, + nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc, + nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, + setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, + sqlifyString : string -> string, + p_cast : string * sql_type -> string, + p_blank : int * sql_type -> string, + supportsDeleteAs : bool, + supportsUpdateAs : bool, + createSequence : string -> string, + textKeysNeedLengths : bool, + supportsNextval : bool, + supportsNestedPrepared : bool, + sqlPrefix : string, + supportsOctetLength : bool, + trueString : string, + falseString : string, + onlyUnion : bool, + nestedRelops : bool, + windowFunctions: bool, + supportsIsDistinctFrom : bool +} + +val dbmses = ref ([] : dbms list) +val curDb = ref ({name = "", + randomFunction = "", + header = "", + link = "", + p_sql_type = fn _ => "", + init = fn _ => Print.box [], + query = fn _ => Print.box [], + queryPrepared = fn _ => Print.box [], + dml = fn _ => Print.box [], + dmlPrepared = fn _ => Print.box [], + nextval = fn _ => Print.box [], + nextvalPrepared = fn _ => Print.box [], + setval = fn _ => Print.box [], + sqlifyString = fn s => s, + p_cast = fn _ => "", + p_blank = fn _ => "", + supportsDeleteAs = false, + supportsUpdateAs = false, + createSequence = fn _ => "", + textKeysNeedLengths = false, + supportsNextval = false, + supportsNestedPrepared = false, + sqlPrefix = "", + supportsOctetLength = false, + trueString = "", + falseString = "", + onlyUnion = false, + nestedRelops = false, + windowFunctions = false, + supportsIsDistinctFrom = false} : dbms) + +fun addDbms v = dbmses := v :: !dbmses +fun setDbms s = + case List.find (fn db => #name db = s) (!dbmses) of + NONE => raise Fail ("Unknown DBMS " ^ s) + | SOME db => curDb := db +fun currentDbms () = !curDb + +val dbstring = ref (NONE : string option) +fun setDbstring so = dbstring := so +fun getDbstring () = !dbstring + +val exe = ref (NONE : string option) +fun setExe so = exe := so +fun getExe () = !exe + +val sql = ref (NONE : string option) +fun setSql so = sql := so +fun getSql () = !sql + +val coreInline = ref 5 +fun setCoreInline n = coreInline := n +fun getCoreInline () = !coreInline + +val monoInline = ref 5 +fun setMonoInline n = monoInline := n +fun getMonoInline () = !monoInline + +val staticLinking = ref false +fun setStaticLinking b = staticLinking := b +fun getStaticLinking () = !staticLinking + +val bootLinking = ref false +fun setBootLinking b = bootLinking := b +fun getBootLinking () = !bootLinking + +val deadlines = ref false +fun setDeadlines b = deadlines := b +fun getDeadlines () = !deadlines + +val sigFile = ref (NONE : string option) +fun setSigFile v = sigFile := v +fun getSigFile () = !sigFile + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +val safeGet = ref SS.empty +fun setSafeGets ls = safeGet := SS.addList (SS.empty, ls) +fun isSafeGet x = SS.member (!safeGet, x) + +val onError = ref (NONE : (string * string list * string) option) +fun setOnError x = onError := x +fun getOnError () = !onError + +val limits = ["messages", "clients", "headers", "page", "heap", "script", + "inputs", "subinputs", "cleanup", "deltas", "transactionals", + "globals", "database", "time"] + +val limitsList = ref ([] : (string * int) list) +fun addLimit (v as (name, _)) = + if List.exists (fn name' => name' = name) limits then + (limitsList := v :: !limitsList; + if name = "time" then + setDeadlines true + else + ()) + else + raise Fail ("Unknown limit category '" ^ name ^ "'") +fun limits () = !limitsList + +val minHeap = ref 0 +fun setMinHeap n = if n >= 0 then minHeap := n else raise Fail "Trying to set negative minHeap" +fun getMinHeap () = !minHeap + +val alwaysInline = ref SS.empty +fun addAlwaysInline s = alwaysInline := SS.add (!alwaysInline, s) +fun checkAlwaysInline s = SS.member (!alwaysInline, s) + +val neverInline = ref SS.empty +fun addNeverInline s = neverInline := SS.add (!neverInline, s) +fun checkNeverInline s = SS.member (!neverInline, s) + +val noXsrfProtection = ref SS.empty +fun addNoXsrfProtection s = noXsrfProtection := SS.add (!noXsrfProtection, s) +fun checkNoXsrfProtection s = SS.member (!noXsrfProtection, s) + +val timeFormat = ref "%c" +fun setTimeFormat v = timeFormat := v +fun getTimeFormat () = !timeFormat + +fun lowercase s = + case s of + "" => "" + | _ => str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun capitalize s = + case s of + "" => "" + | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +val allLower = CharVector.map Char.toLower + +val mangle = ref true +fun setMangleSql x = mangle := x + +fun mangleSqlTable s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ capitalize s + else + lowercase s + +fun mangleSql s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s + +fun mangleSqlCatalog s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s + +val html5 = ref true +fun setIsHtml5 b = html5 := b +fun getIsHtml5 () = !html5 + +val less = ref false +fun setLessSafeFfi b = less := b +fun getLessSafeFfi () = !less + +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +val noMimeFile = ref false + +fun noMime () = + (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n"); + noMimeFile := true; + SM.empty) + +fun readMimeTypes () = + let + val inf = FileIO.txtOpenIn "/etc/mime.types" + + fun loop m = + case TextIO.inputLine inf of + NONE => m + | SOME line => + if size line > 0 andalso String.sub (line, 0) = #"#" then + loop m + else + case String.tokens Char.isSpace line of + typ :: exts => + loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts) + | _ => loop m + in + loop SM.empty + before TextIO.closeIn inf + end handle IO.Io _ => noMime () + | OS.SysErr _ => noMime () + +val mimeTypes = ref (NONE : string SM.map option) + +fun getMimeTypes () = + case !mimeTypes of + SOME m => m + | NONE => + let + val m = readMimeTypes () + in + mimeTypes := SOME m; + m + end + +fun mimeTypeOf filename = + case OS.Path.ext filename of + NONE => (if !noMimeFile then + () + else + TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n"); + NONE) + | SOME ext => + let + val to = SM.find (getMimeTypes (), ext) + in + case to of + NONE => if !noMimeFile then + () + else + TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n") + | _ => (); + to + end + +val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map) + +val filePath = ref "." + +fun setFilePath path = filePath := path + +fun addFile {Uri, LoadFromFilename} = + let + val path = OS.Path.concat (!filePath, LoadFromFilename) + in + case SM.find (!files, Uri) of + SOME (path', _) => + if OS.Path.mkCanonical path' = OS.Path.mkCanonical path then + () + else + ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")") + | NONE => + let + val inf = FileIO.binOpenIn path + in + files := SM.insert (!files, + Uri, + (path, + {Uri = Uri, + ContentType = mimeTypeOf path, + LastModified = OS.FileSys.modTime path, + Bytes = BinIO.inputAll inf})); + BinIO.closeIn inf + end + end handle IO.Io _ => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename) + | OS.SysErr (s, _) => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")") + +fun listFiles () = map #2 (SM.listItems (!files)) + +val jsFiles = ref (SM.empty : {Filename : string, Content : string} SM.map) + +fun addJsFile LoadFromFilename = + let + val path = OS.Path.concat (!filePath, LoadFromFilename) + val inf = FileIO.txtOpenIn path + in + jsFiles := SM.insert (!jsFiles, + path, + {Filename = LoadFromFilename, + Content = TextIO.inputAll inf}); + TextIO.closeIn inf + end handle IO.Io _ => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename) + | OS.SysErr (s, _) => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")") + +fun listJsFiles () = SM.listItems (!jsFiles) + +val jsOutput = ref (NONE : string option) +fun setOutputJsFile so = jsOutput := so +fun getOutputJsFile () = !jsOutput + +fun reset () = + (Globals.setResetTime (); + urlPrefixFull := "/"; + urlPrefix := "/"; + urlPrePrefix := ""; + timeout := 0; + headers := []; + scripts := []; + clientToServer := clientToServerBase; + effectful := effectfulBase; + benign := benignBase; + client := clientBase; + server := serverBase; + jsFuncs := jsFuncsBase; + rewrites := []; + url := []; + mime := []; + request := []; + response := []; + env := []; + meta := []; + debug := false; + dbstring := NONE; + exe := NONE; + sql := NONE; + coreInline := 5; + monoInline := 5; + staticLinking := false; + deadlines := false; + sigFile := NONE; + safeGet := SS.empty; + onError := NONE; + limitsList := []; + minHeap := 0; + alwaysInline := SS.empty; + neverInline := SS.empty; + noXsrfProtection := SS.empty; + timeFormat := "%c"; + mangle := true; + html5 := false; + less := false; + noMimeFile := false; + mimeTypes := NONE; + files := SM.empty; + jsFiles := SM.empty; + filePath := "."; + jsOutput := NONE) + +end diff --git a/src/sha1.sig b/src/sha1.sig new file mode 100644 index 0000000..7fda97f --- /dev/null +++ b/src/sha1.sig @@ -0,0 +1,31 @@ + +(* Implementation the SHA-1 hash function. + Written by Tom 7 in 2004; code in the public domain. *) + +signature SHA1 = +sig + + (* Perform the SHA-1 hash function on a message. + Returns the 160 bit (20 byte) hash. + + recall that string = CharVector.vector. + The input string may contain non-ascii data; + the output certainly will. *) + + val hash : string -> string + + (* pass in a stream as stateful function that returns + SOME s for some non-empty prefix of the remainder of + the stream, or NONE when the stream has ended. *) + val hash_stream : (unit -> string option) -> string + + (* XXX move to hashutil *) + (* convert a binary string to one built of hex digits *) + val bintohex : string -> string + + (* Parse a hexadecimal SHA-1 string. Uppercase and lowercase + are permitted. If the string is not the right length or + contains invalid characters, returns NONE. *) + val parse_hex : string -> string option + +end diff --git a/src/sha1.sml b/src/sha1.sml new file mode 100644 index 0000000..d962c4e --- /dev/null +++ b/src/sha1.sml @@ -0,0 +1,264 @@ + +(* RFC-3174 (SHA-1) hashing function. + By Tom 7, 2004: Code placed in the public domain. +*) + +structure SHA1 :> SHA1 = +struct + exception Unimplemented + + val xorb = Word32.xorb + val andb = Word32.andb + val orb = Word32.orb + val << = Word32.<< + val >> = Word32.>> + val notb = Word32.notb + val ++ = Word32.+ + + type w32 = word + infix xorb andb orb << >> ++ + + (* workaround for andb bug in MLton 20010706 *) + fun mkbyte w = Word32.mod (w, 0w256) + + fun ROL(X, N : Word.word) = (X << N) orb (X >> (0w32-N)) + + fun wc hi lo = (hi << 0w16) orb lo + + fun w2b w = map chr + [Word32.toInt (mkbyte (w >> 0w24)), + Word32.toInt (mkbyte (w >> 0w16)), + Word32.toInt (mkbyte (w >> 0w8)), + Word32.toInt (mkbyte w)] + + (* the length (arg in bytes, output in bits) + as a 64-bit quantity, big-endian *) + fun lenbits l = + implode (List.tabulate (4, fn _ => chr 0)) ^ + implode (w2b (Word32.fromInt (l * 8))) + + + (* executes f for each index lo..hi-1 inclusive *) + fun for lo hi f = + if lo >= hi then () + else (ignore (f lo); for (lo + 1) hi f) + + fun ford lo hi b f = + if lo >= hi then b + else + let + val b = f (lo, b) + in + (ford (lo + 1) hi b f) + end + + fun doblock (aa, bb, cc, dd, ee) msg = + let + val K0 = wc 0wx5A82 0wx7999 + val K1 = wc 0wx6ED9 0wxEBA1 + val K2 = wc 0wx8F1B 0wxBCDC + val K3 = wc 0wxCA62 0wxC1D6 + + fun mb n = Word32.fromInt (ord (CharVector.sub(msg, n))) + + val W = Array.array(80, 0w0) + fun Ws x = Array.sub(W, x) + + val _ = + for 0 16 + (fn t => + let in + Array.update(W, t, + (mb (t * 4 ) << 0w24) orb + (mb (t * 4 + 1) << 0w16) orb + (mb (t * 4 + 2) << 0w8) orb + (mb (t * 4 + 3))) + end) + + val _ = + for 16 80 + (fn t => + let + val n = + Ws (t-3) xorb + Ws (t-8) xorb + Ws (t-14) xorb + Ws (t-16) + val zz = ROL(n, 0w1) + in + Array.update(W, t, zz) + end) + + + val (A, B, C, D, E) = (aa, bb, cc, dd, ee) + + + fun round lo hi f k ctxt = + ford lo hi ctxt + (fn (t, ctxt as (A, B, C, D, E)) => + let + val temp = ROL(A, 0w5) ++ (f ctxt) ++ E ++ Ws t ++ k + val E = D; + val D = C; + val C = ROL(B, 0w30) + val B = A + val A = temp + in + (A, B, C, D, E) + end) + + val (A, B, C, D, E) = + round 0 20 (fn (A, B, C, D, E) => + ((B andb C) orb ((notb B) andb D))) + K0 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 20 40 (fn (A, B, C, D, E) => + (B xorb C xorb D)) + K1 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 40 60 (fn (A, B, C, D, E) => + ((B andb C) orb (B andb D) orb (C andb D))) + K2 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 60 80 (fn (A, B, C, D, E) => + (B xorb C xorb D)) + K3 (A, B, C, D, E) + + in + (aa ++ A, bb ++ B, cc ++ C, dd ++ D, ee ++ E) + end + + datatype 'a stream = + Cons of ('a * (unit -> 'a stream)) + | Nil + + (* turn a stream of oddly chunked strings into + one with 512-bit blocks *) + fun chunk_512 s = + let + + (* the padding required to make a message of length l (bytes) + a proper SHA-1 input. Returns either one or two Cons cells. + tail is the end of the input (63 bytes or less) + l is the total length of the input, *including* the length of the + tail end *) + fun padding tail l = + let val v = l mod 64 in + if v < 56 then + let val p = 56 - v + val padding = implode (List.tabulate (p - 1, fn _ => chr 0)) + in Cons (tail ^ str (chr 0x80) ^ padding ^ lenbits l, + fn _ => Nil) + end + else if v < 64 then + let val p = 64 - v + val padding1 = implode (List.tabulate (p - 1, fn _ => chr 0)) + val padding2 = implode (List.tabulate (56, fn _ => chr 0)) + in Cons (tail ^ str (chr 0x80) ^ padding1, + fn _ => Cons (padding2 ^ lenbits l, fn _ => Nil)) + end + else raise Unimplemented (* Impossible? *) + end + + (* n is the bytes we've already output. + cur is a string (of 64 bytes or less) that will + be our next chunk. + rest,sofar is a string and index indicating the + next bit of data. *) + (* PERF Could be more efficient by using an + accumulating array instead of a string for cur *) + fun ch n cur sofar startat () = + (* if we already have 64 bytes, return it *) + if size cur = 64 + then + let in + Cons(cur, ch (n + 64) "" sofar startat) + end + else + (* do we have any in 'sofar'? *) + if startat < size sofar + then let + val get = Int.min(size sofar - startat, + 64 - size cur) + in + (* be eager, since we need to return something now *) + ch n (cur ^ String.substring(sofar, startat, get)) + sofar (startat + get) () + end + else + (* sofar has been exhausted, + so get some from input stream *) + (case s () of + (* eager, again *) + SOME ss => ch n cur ss 0 () + | NONE => + (* no more data. *) + padding cur (n + size cur)) + in + ch 0 "" "" 0 + end + + fun hash_stream orig_stream = + let + + val stream512 = chunk_512 orig_stream + + (* gets hash context, length of string so far (bytes), + and tail of stream *) + fun hash_rest stream ctxt = + (case stream() of + Cons (s, stream) => + let val ctxt = doblock ctxt s + in hash_rest stream ctxt + end + | Nil => ctxt) + + val init = + (wc 0wx6745 0wx2301, + wc 0wxefcd 0wxab89, + wc 0wx98ba 0wxdcfe, + wc 0wx1032 0wx5476, + wc 0wxc3d2 0wxe1f0) + + val (a, b, c, d, e) = hash_rest stream512 init + in + implode (w2b a @ w2b b @ w2b c @ w2b d @ w2b e) + end + + fun hash m = + hash_stream + (let val r = ref true + in (fn () => + if !r + then (r := false; SOME m) + else NONE) + end) + + val digits = "0123456789ABCDEF" + fun bintohex s = + String.translate (fn c => + implode [CharVector.sub (digits, ord c div 16), + CharVector.sub (digits, ord c mod 16)]) s + + (* ASCII trick: (ch | 4400) % 55 *) + fun hexvalue ch = + SysWord.toInt (SysWord.orb(SysWord.fromInt(ord ch), SysWord.fromInt 4400)) mod 55 + + fun parse_hex s = + if size s <> 40 + orelse not (CharVector.all (fn c => (ord c >= ord #"0" andalso + ord c <= ord #"9") orelse + (ord c >= ord #"a" andalso + ord c <= ord #"f") orelse + (ord c >= ord #"A" andalso + ord c <= ord #"F")) s) + then NONE + else SOME (CharVector.tabulate(20, + (fn i => + chr(hexvalue (String.sub(s, i * 2)) * 16 + + hexvalue (String.sub(s, i * 2 + 1)))))) + +end diff --git a/src/shake.sig b/src/shake.sig new file mode 100644 index 0000000..2b805de --- /dev/null +++ b/src/shake.sig @@ -0,0 +1,37 @@ +(* Copyright (c) 2008, 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. + *) + +(* Remove unused definitions from a file *) + +signature SHAKE = sig + + val shake : Core.file -> Core.file + + val sliceDb : bool ref + (* Set this to try to delete anything not needed to determine the database schema. *) + +end diff --git a/src/shake.sml b/src/shake.sml new file mode 100644 index 0000000..051507d --- /dev/null +++ b/src/shake.sml @@ -0,0 +1,229 @@ +(* Copyright (c) 2008-2010, 2013, 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. + *) + +(* Remove unused definitions from a file *) + +structure Shake :> SHAKE = struct + +val sliceDb = ref false + +open Core + +structure U = CoreUtil + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +type free = { + con : IS.set, + exp : IS.set +} + +val dummyt = (TRecord (CRecord ((KType, ErrorMsg.dummySpan), []), ErrorMsg.dummySpan), ErrorMsg.dummySpan) +val dummye = (EPrim (Prim.String (Prim.Normal, "")), ErrorMsg.dummySpan) + +fun tupleC cs = (CTuple cs, ErrorMsg.dummySpan) +fun tupleE es = (ERecord (map (fn e => (dummyt, e, dummyt)) es), ErrorMsg.dummySpan) + +fun shake file = + let + val usedVarsC = U.Con.fold {kind = fn (_, st) => st, + con = fn (c, cs) => + case c of + CNamed n => IS.add (cs, n) + | _ => cs} + + val usedVars = U.Exp.fold {kind = fn (_, st) => st, + con = fn (c, st as (es, cs)) => + case c of + CNamed n => (es, IS.add (cs, n)) + | _ => st, + exp = fn (e, st as (es, cs)) => + case e of + ENamed n => (IS.add (es, n), cs) + | _ => st} + + val (usedE, usedC) = + List.foldl + (fn ((DExport (_, n, _), _), st as (usedE, usedC)) => + if !sliceDb then + st + else + (IS.add (usedE, n), usedC) + | ((DTable (_, _, c, _, pe, pc, ce, cc), _), (usedE, usedC)) => + let + val usedC = usedVarsC usedC c + val usedC = usedVarsC usedC pc + val usedC = usedVarsC usedC cc + + val (usedE, usedC) = usedVars (usedE, usedC) pe + val (usedE, usedC) = usedVars (usedE, usedC) ce + in + (usedE, usedC) + end + | ((DView (_, _, _, e, c), _), (usedE, usedC)) => + let + val usedC = usedVarsC usedC c + in + usedVars (usedE, usedC) e + end + | ((DTask (e1, e2), _), st) => + if !sliceDb then + st + else + usedVars (usedVars st e1) e2 + | ((DPolicy e1, _), st) => + if !sliceDb then + st + else + usedVars st e1 + | ((DOnError n, _), st as (usedE, usedC)) => + if !sliceDb then + st + else + (IS.add (usedE, n), usedC) + | (_, acc) => acc) (IS.empty, IS.empty) file + + val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) + | ((DDatatype dts, _), (cdef, edef)) => + (foldl (fn ((_, n, _, xncs), cdef) => + IM.insert (cdef, n, List.mapPartial #3 xncs)) cdef dts, edef) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], t, e))) + | ((DValRec vis, _), (cdef, edef)) => + let + val all_ns = map (fn (_, n, _, _, _) => n) vis + in + (cdef, foldl (fn ((_, n, t, e, _), edef) => + IM.insert (edef, n, (all_ns, t, e))) edef vis) + end + | ((DExport _, _), acc) => acc + | ((DTable (_, n, c, _, e1, c1, e2, c2), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], tupleC [c, c1, c2], tupleE [e1, e2]))) + | ((DSequence (_, n, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DView (_, n, _, _, c), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) + | ((DDatabase _, _), acc) => acc + | ((DCookie (_, n, c, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) + | ((DStyle (_, n, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DTask _, _), acc) => acc + | ((DPolicy _, _), acc) => acc + | ((DOnError _, _), acc) => acc) + (IM.empty, IM.empty) file + + fun kind (_, s) = s + + fun con (c, s) = + case c of + CNamed n => + if IS.member (#con s, n) then + s + else + let + val s' = {con = IS.add (#con s, n), + exp = #exp s} + in + case IM.find (cdef, n) of + NONE => s' + | SOME cs => foldl (fn (c, s') => shakeCon s' c) s' cs + end + | _ => s + + and shakeCon s = U.Con.fold {kind = kind, con = con} s + + (*val () = print "=====\nSHAKE\n=====\n" + val current = ref 0*) + + fun exp (e, s) = + let + fun check n = + if IS.member (#exp s, n) then + s + else + let + val s' = {exp = IS.add (#exp s, n), + con = #con s} + in + (*print ("Need " ^ Int.toString n ^ " <-- " ^ Int.toString (!current) ^ "\n");*) + case IM.find (edef, n) of + NONE => s' + | SOME (ns, t, e) => + let + (*val old = !current + val () = current := n*) + val s' = shakeExp (shakeCon s' t) e + in + (*current := old;*) + foldl (fn (n, s') => exp (ENamed n, s')) s' ns + end + end + in + case e of + ENamed n => check n + | EServerCall (n, _, _, _) => check n + | _ => s + end + + and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s + + val s = {con = usedC, exp = usedE} + + val s = IS.foldl (fn (n, s) => + case IM.find (edef, n) of + NONE => raise Fail "Shake: Couldn't find 'val'" + | SOME (ns, t, e) => + let + (*val () = current := n*) + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s usedE + + val s = IS.foldl (fn (n, s) => + case IM.find (cdef, n) of + NONE => raise Fail ("Shake: Couldn't find 'con' " ^ Int.toString n) + | SOME cs => foldl (fn (c, s) => shakeCon s c) s cs) s usedC + in + List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n) + | (DDatatype dts, _) => List.exists (fn (_, n, _, _) => IS.member (#con s, n)) dts + | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis + | (DExport _, _) => not (!sliceDb) + | (DView _, _) => true + | (DSequence _, _) => true + | (DTable _, _) => true + | (DDatabase _, _) => not (!sliceDb) + | (DCookie _, _) => not (!sliceDb) + | (DStyle _, _) => not (!sliceDb) + | (DTask _, _) => not (!sliceDb) + | (DPolicy _, _) => not (!sliceDb) + | (DOnError _, _) => not (!sliceDb)) file + end + +end diff --git a/src/sidecheck.sig b/src/sidecheck.sig new file mode 100644 index 0000000..1e3e227 --- /dev/null +++ b/src/sidecheck.sig @@ -0,0 +1,37 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature SIDE_CHECK = sig + + val check : Mono.file -> Mono.file + + (* While we're checking, we'll do some other signature-related work, recording + * which environment variables are read. This function conveys the list, + * coming from the most recent call to [check]. *) + val readEnvVars : unit -> string list + +end diff --git a/src/sidecheck.sml b/src/sidecheck.sml new file mode 100644 index 0000000..bd11223 --- /dev/null +++ b/src/sidecheck.sml @@ -0,0 +1,84 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure SideCheck :> SIDE_CHECK = struct + +open Mono + +structure E = ErrorMsg + +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) + +val envVars = ref SS.empty + +fun check ds = + let + val alreadyWarned = ref false + in + envVars := SS.empty; + MonoUtil.File.appLoc (fn (e, loc) => + let + fun error (k as (k1, k2)) = + if Settings.isClientOnly k then + let + val k2 = case k1 of + "Basis" => + (case k2 of + "get_client_source" => "get" + | _ => k2) + | _ => k2 + in + E.errorAt loc ("Server-side code uses client-side-only identifier \"" ^ k1 ^ "." ^ k2 ^ "\"") + end + else + () + in + case e of + EFfi k => error k + | EFfiApp ("Basis", "getenv", [(e, _)]) => + (case #1 e of + EPrim (Prim.String (_, s)) => + envVars := SS.add (!envVars, s) + | _ => if !alreadyWarned then + () + else + (alreadyWarned := true; + TextIO.output (TextIO.stdErr, "WARNING: " ^ ErrorMsg.spanToString loc ^ ": reading from an environment variable not determined at compile time, which can confuse CSRF protection"))) + | EFfiApp (k1, k2, _) => error (k1, k2) + | _ => () + end) ds; + ds + end + +fun readEnvVars () = SS.listItems (!envVars) + +end diff --git a/src/sigcheck.sig b/src/sigcheck.sig new file mode 100644 index 0000000..565621c --- /dev/null +++ b/src/sigcheck.sig @@ -0,0 +1,36 @@ +(* Copyright (c) 2013, 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. + *) + +(* Make sure that no global variable initializers mention signature generation, + * because said generation only makes sense in the context of a page view. + * Replace such global variables with functions. *) + +signature SIG_CHECK = sig + + val check : Mono.file -> Mono.file + +end diff --git a/src/sigcheck.sml b/src/sigcheck.sml new file mode 100644 index 0000000..a6ed765 --- /dev/null +++ b/src/sigcheck.sml @@ -0,0 +1,97 @@ +(* Copyright (c) 2013, 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 SigCheck :> SIG_CHECK = struct + +open Mono + +structure IS = IntBinarySet +structure E = ErrorMsg + +fun check (ds, sl) = + let + fun isSiggy siggers = + MonoUtil.Decl.exists {typ = fn _ => false, + decl = fn _ => false, + exp = fn e => + case e of + ERel n => IS.member (siggers, n) + | EFfiApp ("Basis", "sigString", _) => true + | _ => false} + + fun sigify' sigdecs e = + case e of + ENamed n => if IS.member (sigdecs, n) then + (EApp ((e, E.dummySpan), + (ERecord [], E.dummySpan))) + else + e + | _ => e + + fun sigify sigdecs = + MonoUtil.Decl.map {typ = fn x => x, + decl = fn d => d, + exp = sigify' sigdecs} + + fun sigifyE sigdecs = + MonoUtil.Exp.map {typ = fn x => x, + exp = sigify' sigdecs} + + fun isFun (e, _) = + case e of + EAbs _ => true + | _ => false + + fun doDecl (d : decl, (siggers, sigdecs)) = + case #1 d of + DVal (x, n, t, e, s) => + if isSiggy siggers d then + if isFun e then + (sigify sigdecs d, (IS.add (siggers, n), sigdecs)) + else + ((DVal (x, n, (TFun ((TRecord [], #2 d), t), #2 d), + (EAbs ("_", (TRecord [], #2 d), t, sigifyE sigdecs e), #2 d), + s), #2 d), + (IS.add (siggers, n), + IS.add (sigdecs, n))) + else + (sigify sigdecs d, (siggers, sigdecs)) + | DValRec vis => + if isSiggy siggers d then + (sigify sigdecs d, + (foldl IS.add' siggers (map #2 vis), + sigdecs)) + else + (sigify sigdecs d, (siggers, sigdecs)) + | _ => (sigify sigdecs d, (siggers, sigdecs)) + + val (ds, _) = ListUtil.foldlMap doDecl (IS.empty, IS.empty) ds + in + (ds, sl) + end + +end diff --git a/src/source.sml b/src/source.sml new file mode 100644 index 0000000..2d8c1ed --- /dev/null +++ b/src/source.sml @@ -0,0 +1,192 @@ +(* Copyright (c) 2008, 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 Source = struct + +type 'a located = 'a ErrorMsg.located + +datatype kind' = + KType + | KArrow of kind * kind + | KName + | KRecord of kind + | KUnit + | KTuple of kind list + | KWild + + | KFun of string * kind + | KVar of string + +withtype kind = kind' located + +datatype explicitness = + Explicit + | Implicit + +datatype con' = + CAnnot of con * kind + + | TFun of con * con + | TCFun of explicitness * string * kind * con + | TRecord of con + | TDisjoint of con * con * con + + | CVar of string list * string + | CApp of con * con + | CAbs of string * kind option * con + + | CKAbs of string * con + | TKFun of string * con + + | CName of string + + | CRecord of (con * con) list + | CConcat of con * con + | CMap + + | CUnit + + | CTuple of con list + | CProj of con * int + + | CWild of kind + +withtype con = con' located + +datatype inference = + Infer + | DontInfer + | TypesOnly + +datatype sgn_item' = + SgiConAbs of string * kind + | SgiCon of string * kind option * con + | SgiDatatype of (string * string list * (string * con option) list) list + | SgiDatatypeImp of string * string list * string + | SgiVal of string * con + | SgiTable of string * con * exp * exp + | SgiStr of string * sgn + | SgiSgn of string * sgn + | SgiInclude of sgn + | SgiConstraint of con * con + | SgiClassAbs of string * kind + | SgiClass of string * kind * con + +and sgn' = + SgnConst of sgn_item list + | SgnVar of string + | SgnFun of string * sgn * sgn + | SgnWhere of sgn * string list * string * con + | SgnProj of string * string list * string + +and pat' = + PVar of string + | PPrim of Prim.t + | PCon of string list * string * pat option + | PRecord of (string * pat) list * bool + | PAnnot of pat * con + +and exp' = + EAnnot of exp * con + + | EPrim of Prim.t + | EVar of string list * string * inference + | EApp of exp * exp + | EAbs of string * con option * exp + | ECApp of exp * con + | ECAbs of explicitness * string * kind * exp + | EDisjoint of con * con * exp + | EDisjointApp of exp + + | EKAbs of string * exp + + | ERecord of (con * exp) list * bool + | EField of exp * con + | EConcat of exp * exp + | ECut of exp * con + | ECutMulti of exp * con + + | EWild + + | ECase of exp * (pat * exp) list + + | ELet of edecl list * exp + +and edecl' = + EDVal of pat * exp + | EDValRec of (string * con option * exp) list + +withtype sgn_item = sgn_item' located +and sgn = sgn' located +and pat = pat' located +and exp = exp' located +and edecl = edecl' located + +datatype ffi_mode = + Effectful + | BenignEffectful + | ClientOnly + | ServerOnly + | JsFunc of string + +datatype decl' = + DCon of string * kind option * con + | DDatatype of (string * string list * (string * con option) list) list + | DDatatypeImp of string * string list * string + | DVal of pat * exp + | DValRec of (string * con option * exp) list + | DSgn of string * sgn + | DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *) + | DFfiStr of string * sgn * Time.time option + | DOpen of string * string list + | DConstraint of con * con + | DOpenConstraints of string * string list + | DExport of str + | DTable of string * con * exp * exp + | DSequence of string + | DView of string * exp + | DDatabase of string + | DCookie of string * con + | DStyle of string + | DTask of exp * exp + | DPolicy of exp + | DOnError of string * string list * string + | DFfi of string * ffi_mode list * con + + and str' = + StrConst of decl list + | StrVar of string + | StrProj of str * string + | StrFun of string * sgn * sgn option * str + | StrApp of str * str + +withtype decl = decl' located + and str = str' located + +type file = decl list + +end diff --git a/src/source_print.sig b/src/source_print.sig new file mode 100644 index 0000000..f5b0df2 --- /dev/null +++ b/src/source_print.sig @@ -0,0 +1,40 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web *) + +signature SOURCE_PRINT = sig + val p_kind : Source.kind Print.printer + val p_explicitness : Source.explicitness Print.printer + val p_con : Source.con Print.printer + val p_exp : Source.exp Print.printer + val p_decl : Source.decl Print.printer + val p_edecl : Source.edecl Print.printer + val p_sgn_item : Source.sgn_item Print.printer + val p_str : Source.str Print.printer + val p_file : Source.file Print.printer +end diff --git a/src/source_print.sml b/src/source_print.sml new file mode 100644 index 0000000..e18a82f --- /dev/null +++ b/src/source_print.sml @@ -0,0 +1,728 @@ +(* Copyright (c) 2008, 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. + *) + +(* Pretty-printing Ur/Web *) + +structure SourcePrint :> SOURCE_PRINT = struct + +open Print.PD +open Print + +open Source + +fun p_kind' par (k, _) = + case k of + KType => string "Type" + | KArrow (k1, k2) => parenIf par (box [p_kind' true k1, + space, + string "->", + space, + p_kind k2]) + | KName => string "Name" + | KRecord k => box [string "{", p_kind k, string "}"] + | KUnit => string "Unit" + | KWild => string "_" + | KTuple ks => box [string "(", + p_list_sep (box [space, string "*", space]) p_kind ks, + string ")"] + + | KVar x => string x + | KFun (x, k) => box [string x, + space, + string "-->", + space, + p_kind k] + +and p_kind k = p_kind' false k + +fun p_explicitness e = + case e of + Explicit => string "::" + | Implicit => string ":::" + +fun p_con' par (c, _) = + case c of + CAnnot (c, k) => box [string "(", + p_con c, + space, + string "::", + space, + p_kind k, + string ")"] + + | TFun (t1, t2) => parenIf par (box [p_con' true t1, + space, + string "->", + space, + p_con t2]) + | TCFun (e, x, k, c) => parenIf par (box [string x, + space, + p_explicitness e, + space, + p_kind k, + space, + string "->", + space, + p_con c]) + | TRecord (CRecord xcs, _) => box [string "{", + p_list (fn (x, c) => + box [p_name x, + space, + string ":", + space, + p_con c]) xcs, + string "}"] + | TRecord c => box [string "$", + p_con' true c] + | TDisjoint (c1, c2, c3) => parenIf par (box [string "[", + p_con c1, + space, + string "~", + space, + p_con c2, + string "]", + space, + string "=>", + space, + p_con c3]) + + | CVar (ss, s) => p_list_sep (string ".") string (ss @ [s]) + | CApp (c1, c2) => parenIf par (box [p_con c1, + space, + p_con' true c2]) + | CAbs (x, NONE, c) => parenIf par (box [string "fn", + space, + string x, + space, + string "=>", + space, + p_con c]) + | CAbs (x, SOME k, c) => parenIf par (box [string "fn", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=>", + space, + p_con c]) + + + | CName s => box [string "#", string s] + + | CRecord xcs => box [string "[", + p_list (fn (x, c) => + box [p_con x, + space, + string "=", + space, + p_con c]) xcs, + string "]"] + | CConcat (c1, c2) => parenIf par (box [p_con' true c1, + space, + string "++", + space, + p_con c2]) + | CMap => string "map" + + | CUnit => string "()" + + | CWild k => box [string "(_", + space, + string "::", + space, + p_kind k, + string ")"] + + | CTuple cs => box [string "(", + p_list p_con cs, + string ")"] + | CProj (c, n) => box [p_con c, + string ".", + string (Int.toString n)] + + | CKAbs (x, c) => box [string x, + space, + string "==>", + space, + p_con c] + | TKFun (x, c) => box [string x, + space, + string "-->", + space, + p_con c] + +and p_con c = p_con' false c + +and p_name (all as (c, _)) = + case c of + CName s => string s + | _ => p_con all + +fun p_pat' par (p, _) = + case p of + PVar s => string s + | PPrim p => Prim.p_t p + | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x]) + | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]), + space, + p_pat' true p]) + | PRecord (xps, flex) => + let + val pps = map (fn (x, p) => box [string x, space, string "=", space, p_pat p]) xps + in + box [string "{", + p_list_sep (box [string ",", space]) (fn x => x) + (if flex then + pps @ [string "..."] + else + pps), + string "}"] + end + + | PAnnot (p, t) => box [p_pat p, + space, + string ":", + space, + p_con t] + +and p_pat x = p_pat' false x + +fun p_exp' par (e, _) = + case e of + EAnnot (e, t) => box [string "(", + p_exp e, + space, + string ":", + space, + p_con t, + string ")"] + + | EPrim p => Prim.p_t p + | EVar (ss, s, _) => p_list_sep (string ".") string (ss @ [s]) + | EApp (e1, e2) => parenIf par (box [p_exp e1, + space, + p_exp' true e2]) + | EAbs (x, NONE, e) => parenIf par (box [string "fn", + space, + string x, + space, + string "=>", + space, + p_exp e]) + | EAbs (x, SOME t, e) => parenIf par (box [string "fn", + space, + string x, + space, + string ":", + space, + p_con t, + space, + string "=>", + space, + p_exp e]) + | ECApp (e, c) => parenIf par (box [p_exp e, + space, + string "[", + p_con c, + string "]"]) + | ECAbs (exp, x, k, e) => parenIf par (box [string "fn", + space, + string x, + space, + p_explicitness exp, + space, + p_kind k, + space, + string "=>", + space, + p_exp e]) + | EDisjoint (c1, c2, e) => parenIf par (box [p_con c1, + space, + string "~", + space, + p_con c2, + space, + string "=>", + space, + p_exp e]) + | EDisjointApp e => parenIf par (box [p_exp e, + space, + string "!"]) + + | ERecord (xes, flex) => box [string "{", + p_list (fn (x, e) => + box [p_name x, + space, + string "=", + space, + p_exp e]) xes, + if flex then + box [string ",", + space, + string "..."] + else + box [], + string "}"] + | EField (e, c) => box [p_exp' true e, + string ".", + p_con' true c] + | EConcat (e1, e2) => parenIf par (box [p_exp' true e1, + space, + string "++", + space, + p_exp' true e2]) + | ECut (e, c) => parenIf par (box [p_exp' true e, + space, + string "--", + space, + p_con' true c]) + | ECutMulti (e, c) => parenIf par (box [p_exp' true e, + space, + string "---", + space, + p_con' true c]) + | ECase (e, pes) => parenIf par (box [string "case", + space, + p_exp e, + space, + string "of", + space, + p_list_sep (box [space, string "|", space]) + (fn (p, e) => box [p_pat p, + space, + string "=>", + space, + p_exp e]) pes]) + + | EWild => string "_" + + | ELet (ds, e) => box [string "let", + newline, + box [p_list_sep newline p_edecl ds], + newline, + string "in", + newline, + box [p_exp e], + newline, + string "end"] + + | EKAbs (x, e) => box [string x, + space, + string "-->", + space, + p_exp e] + +and p_exp e = p_exp' false e + +and p_edecl (d, _) = + case d of + EDVal (p, e) => box [string "val", + space, + p_pat p, + space, + string "=", + space, + p_exp e] + | EDValRec vis => box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) p_vali vis] + +and p_vali (x, co, e) = + case co of + NONE => box [string x, + space, + string "=", + space, + p_exp e] + | SOME t => box [string x, + space, + string ":", + space, + p_con t, + space, + string "=", + space, + p_exp e] + + +fun p_datatype (x, xs, cons) = + box [string x, + p_list_sep (box []) (fn x => box [space, string x]) xs, + space, + string "=", + space, + p_list_sep (box [space, string "|", space]) + (fn (x, NONE) => string x + | (x, SOME t) => box [string x, space, string "of", space, p_con t]) + cons] + +fun p_sgn_item (sgi, _) = + case sgi of + SgiConAbs (x, k) => box [string "con", + space, + string x, + space, + string "::", + space, + p_kind k] + | SgiCon (x, NONE, c) => box [string "con", + space, + string x, + space, + string "=", + space, + p_con c] + | SgiCon (x, SOME k, c) => box [string "con", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + | SgiDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) p_datatype x] + | SgiDatatypeImp (x, ms, x') => + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (ms @ [x'])] + | SgiVal (x, c) => box [string "val", + space, + string x, + space, + string ":", + space, + p_con c] + | SgiTable (x, c, pe, ce) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "keys", + space, + p_exp pe, + space, + string "constraints", + space, + p_exp ce] + | SgiStr (x, sgn) => box [string "structure", + space, + string x, + space, + string ":", + space, + p_sgn sgn] + | SgiSgn (x, sgn) => box [string "signature", + space, + string x, + space, + string "=", + space, + p_sgn sgn] + | SgiInclude sgn => box [string "include", + space, + p_sgn sgn] + | SgiConstraint (c1, c2) => box [string "constraint", + space, + p_con c1, + space, + string "~", + space, + p_con c2] + | SgiClassAbs (x, k) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k] + | SgiClass (x, k, c) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + +and p_sgn (sgn, _) = + case sgn of + SgnConst sgis => box [string "sig", + newline, + p_list_sep newline p_sgn_item sgis, + newline, + string "end"] + | SgnVar x => string x + | SgnFun (x, sgn, sgn') => box [string "functor", + space, + string "(", + string x, + space, + string ":", + p_sgn sgn, + string ")", + space, + string ":", + space, + p_sgn sgn'] + | SgnWhere (sgn, ms, x, c) => box [p_sgn sgn, + space, + string "where", + space, + string "con", + space, + p_list_sep (string ".") + string (ms @ [x]), + string x, + space, + string "=", + space, + p_con c] + | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x]) + + + +fun p_decl ((d, _) : decl) = + case d of + DCon (x, NONE, c) => box [string "con", + space, + string x, + space, + string "=", + space, + p_con c] + | DCon (x, SOME k, c) => box [string "con", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + | DDatatype x => box [string "datatype", + space, + p_list_sep (box [space, string "and", space]) p_datatype x] + | DDatatypeImp (x, ms, x') => + box [string "datatype", + space, + string x, + space, + string "=", + space, + string "datatype", + space, + p_list_sep (string ".") string (ms @ [x'])] + | DVal (p, e) => box [string "val", + space, + p_pat p, + space, + string "=", + space, + p_exp e] + | DValRec vis => box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) p_vali vis] + + | DSgn (x, sgn) => box [string "signature", + space, + string x, + space, + string "=", + space, + p_sgn sgn] + | DStr (x, NONE, _, str, _) => box [string "structure", + space, + string x, + space, + string "=", + space, + p_str str] + | DStr (x, SOME sgn, _, str, _) => box [string "structure", + space, + string x, + space, + string ":", + space, + p_sgn sgn, + space, + string "=", + space, + p_str str] + | DFfiStr (x, sgn, _) => box [string "extern", + space, + string "structure", + space, + string x, + space, + string ":", + space, + p_sgn sgn] + | DOpen (m, ms) => box [string "open", + space, + p_list_sep (string ".") string (m :: ms)] + | DConstraint (c1, c2) => box [string "constraint", + space, + p_con c1, + space, + string "~", + space, + p_con c2] + | DOpenConstraints (m, ms) => box [string "open", + space, + string "constraints", + space, + p_list_sep (string ".") string (m :: ms)] + + | DExport str => box [string "export", + space, + p_str str] + | DTable (x, c, pe, ce) => box [string "table", + space, + string x, + space, + string ":", + space, + p_con c, + space, + string "keys", + space, + p_exp pe, + space, + string "constraints", + space, + p_exp ce] + | DSequence x => box [string "sequence", + space, + string x] + | DView (x, e) => box [string "view", + space, + string x, + space, + string "=", + space, + p_exp e] + + | DDatabase s => box [string "database", + space, + string s] + + | DCookie (x, c) => box [string "cookie", + space, + string x, + space, + string ":", + space, + p_con c] + | DStyle x => box [string "style", + space, + string x] + | DTask (e1, e2) => box [string "task", + space, + p_exp e1, + space, + string "=", + space, + p_exp e2] + | DPolicy e1 => box [string "policy", + space, + p_exp e1] + | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" + +and p_str (str, _) = + case str of + StrConst ds => box [string "struct", + newline, + p_list_sep newline p_decl ds, + newline, + string "end"] + | StrVar x => string x + | StrProj (str, x) => box [p_str str, + string ".", + string x] + | StrFun (x, sgn, NONE, str) => box [string "functor", + space, + string "(", + string x, + space, + string ":", + p_sgn sgn, + string ")", + space, + string "=>", + space, + p_str str] + | StrFun (x, sgn, SOME sgn', str) => box [string "functor", + space, + string "(", + string x, + space, + string ":", + p_sgn sgn, + string ")", + space, + string ":", + space, + p_sgn sgn', + space, + string "=>", + space, + p_str str] + | StrApp (str1, str2) => box [p_str str1, + string "(", + p_str str2, + string ")"] + +val p_file = p_list_sep newline p_decl + +end diff --git a/src/sources b/src/sources new file mode 100644 index 0000000..52b1bdd --- /dev/null +++ b/src/sources @@ -0,0 +1,272 @@ +$(SRC)/config.sig +config.sml + +$(SRC)/globals.sig +$(SRC)/globals.sml + +$(SRC)/search.sig +$(SRC)/search.sml + +$(SRC)/list_util.sig +$(SRC)/list_util.sml + +$(SRC)/order.sig +$(SRC)/order.sml + +$(SRC)/errormsg.sig +$(SRC)/errormsg.sml + +$(SRC)/print.sig +$(SRC)/print.sml + +$(SRC)/fileio.sig +$(SRC)/fileio.sml + +$(SRC)/settings.sig +$(SRC)/settings.sml + +$(SRC)/http.sig +$(SRC)/http.sml + +$(SRC)/cgi.sig +$(SRC)/cgi.sml + +$(SRC)/fastcgi.sig +$(SRC)/fastcgi.sml + +$(SRC)/static.sig +$(SRC)/static.sml + +$(SRC)/prim.sig +$(SRC)/prim.sml + +$(SRC)/mysql.sig +$(SRC)/mysql.sml + +$(SRC)/sqlite.sig +$(SRC)/sqlite.sml + +$(SRC)/datatype_kind.sml + +$(SRC)/export.sig +$(SRC)/export.sml + +$(SRC)/source.sml + +$(SRC)/utf8.sig +$(SRC)/utf8.sml + +../xml/entities.sml + +urweb.grm +urweb.lex + +$(SRC)/source_print.sig +$(SRC)/source_print.sml + +$(SRC)/elab.sml + +$(SRC)/elab_util.sig +$(SRC)/elab_util.sml + +$(SRC)/elab_env.sig +$(SRC)/elab_env.sml + +$(SRC)/elab_print.sig +$(SRC)/elab_print.sml + +$(SRC)/elab_ops.sig +$(SRC)/elab_ops.sml + +$(SRC)/disjoint.sig +$(SRC)/disjoint.sml + +$(SRC)/elab_err.sig +$(SRC)/elab_err.sml + +$(SRC)/mod_db.sig +$(SRC)/mod_db.sml + +$(SRC)/elaborate.sig +$(SRC)/elaborate.sml + +$(SRC)/unnest.sig +$(SRC)/unnest.sml + +$(SRC)/termination.sig +$(SRC)/termination.sml + +$(SRC)/expl.sml + +$(SRC)/expl_util.sig +$(SRC)/expl_util.sml + +$(SRC)/expl_env.sig +$(SRC)/expl_env.sml + +$(SRC)/expl_print.sig +$(SRC)/expl_print.sml + +$(SRC)/explify.sig +$(SRC)/explify.sml + +$(SRC)/core.sml + +$(SRC)/core_util.sig +$(SRC)/core_util.sml + +$(SRC)/core_env.sig +$(SRC)/core_env.sml + +$(SRC)/core_print.sig +$(SRC)/core_print.sml + +$(SRC)/expl_rename.sig +$(SRC)/expl_rename.sml + +$(SRC)/corify.sig +$(SRC)/corify.sml + +$(SRC)/reduce_local.sig +$(SRC)/reduce_local.sml + +$(SRC)/shake.sig +$(SRC)/shake.sml + +$(SRC)/core_untangle.sig +$(SRC)/core_untangle.sml + +$(SRC)/especialize.sig +$(SRC)/especialize.sml + +$(SRC)/reduce.sig +$(SRC)/reduce.sml + +$(SRC)/unpoly.sig +$(SRC)/unpoly.sml + +$(SRC)/specialize.sig +$(SRC)/specialize.sml + +$(SRC)/rpcify.sig +$(SRC)/rpcify.sml + +$(SRC)/tag.sig +$(SRC)/tag.sml + +$(SRC)/effectize.sig +$(SRC)/effectize.sml + +$(SRC)/marshalcheck.sig +$(SRC)/marshalcheck.sml + +$(SRC)/css.sig +$(SRC)/css.sml + +$(SRC)/mono.sml + +$(SRC)/mono_util.sig +$(SRC)/mono_util.sml + +$(SRC)/mono_env.sig +$(SRC)/mono_env.sml + +$(SRC)/mono_print.sig +$(SRC)/mono_print.sml + +$(SRC)/mono_fooify.sig +$(SRC)/mono_fooify.sml + +$(SRC)/sql.sig +$(SRC)/sql.sml + +$(SRC)/union_find_fn.sml +$(SRC)/multimap_fn.sml + +$(SRC)/list_key_fn.sml +$(SRC)/option_key_fn.sml +$(SRC)/pair_key_fn.sml +$(SRC)/triple_key_fn.sml + +$(SRC)/cache.sml +$(SRC)/toy_cache.sml +$(SRC)/lru_cache.sml + +$(SRC)/monoize.sig +$(SRC)/monoize.sml + +$(SRC)/mono_reduce.sig +$(SRC)/mono_reduce.sml + +$(SRC)/mono_opt.sig +$(SRC)/mono_opt.sml + +$(SRC)/untangle.sig +$(SRC)/untangle.sml + +$(SRC)/mono_shake.sig +$(SRC)/mono_shake.sml + +$(SRC)/fuse.sig +$(SRC)/fuse.sml + +$(SRC)/iflow.sig +$(SRC)/iflow.sml + +$(SRC)/sqlcache.sig +$(SRC)/sqlcache.sml + +$(SRC)/name_js.sig +$(SRC)/name_js.sml + +$(SRC)/jscomp.sig +$(SRC)/jscomp.sml + +$(SRC)/pathcheck.sig +$(SRC)/pathcheck.sml + +$(SRC)/sidecheck.sig +$(SRC)/sidecheck.sml + +$(SRC)/sigcheck.sig +$(SRC)/sigcheck.sml + +$(SRC)/mono_inline.sml + +$(SRC)/sha1.sig +$(SRC)/sha1.sml + +$(SRC)/cjr.sml + +$(SRC)/postgres.sig +$(SRC)/postgres.sml + +$(SRC)/cjr_env.sig +$(SRC)/cjr_env.sml + +$(SRC)/cjr_print.sig +$(SRC)/cjr_print.sml + +$(SRC)/cjrize.sig +$(SRC)/cjrize.sml + +$(SRC)/scriptcheck.sig +$(SRC)/scriptcheck.sml + +$(SRC)/dbmodecheck.sig +$(SRC)/dbmodecheck.sml + +$(SRC)/prepare.sig +$(SRC)/prepare.sml + +$(SRC)/checknest.sig +$(SRC)/checknest.sml + +$(SRC)/compiler.sig +$(SRC)/compiler.sml + +$(SRC)/demo.sig +$(SRC)/demo.sml + +$(SRC)/tutorial.sig +$(SRC)/tutorial.sml diff --git a/src/specialize.sig b/src/specialize.sig new file mode 100644 index 0000000..9b0d1e8 --- /dev/null +++ b/src/specialize.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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. + *) + +(* Simplify a Core program by repeating polymorphic definitions of datatypes *) + +signature SPECIALIZE = sig + + val specialize : Core.file -> Core.file + +end diff --git a/src/specialize.sml b/src/specialize.sml new file mode 100644 index 0000000..3354525 --- /dev/null +++ b/src/specialize.sml @@ -0,0 +1,298 @@ +(* 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. + *) + +(* Simplify a Core program by repeating polymorphic definitions of datatypes *) + +structure Specialize :> SPECIALIZE = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +val liftConInCon = E.liftConInCon +val subConInCon = E.subConInCon + +structure CK = struct +type ord_key = con list +val compare = Order.joinL U.Con.compare +end + +structure CM = BinaryMapFn(CK) +structure IM = IntBinaryMap + +type datatyp' = { + name : int, + constructors : int IM.map +} + +type datatyp = { + name : string, + params : int, + constructors : (string * int * con option) list, + specializations : datatyp' CM.map +} + +type state = { + count : int, + datatypes : datatyp IM.map, + constructors : int IM.map, + decls : (string * int * string list * (string * int * con option) list) list +} + +fun kind (k, st) = (k, st) + +val isOpen = U.Con.exists {kind = fn _ => false, + con = fn c => + case c of + CRel _ => true + | _ => false} + +fun considerSpecialization (st : state, n, args, dt : datatyp) = + let + val args = map ReduceLocal.reduceCon args + in + case CM.find (#specializations dt, args) of + SOME dt' => (#name dt', #constructors dt', st) + | NONE => + let + (*val () = Print.prefaces "Args" [("n", Print.PD.string (Int.toString n)), + ("args", Print.p_list (CorePrint.p_con CoreEnv.empty) args)]*) + + val n' = #count st + + val nxs = length args - 1 + fun sub t = ListUtil.foldli (fn (i, arg, t) => + subConInCon (nxs - i, arg) t) t args + + val (cons, (count, cmap)) = + ListUtil.foldlMap (fn ((x, n, to), (count, cmap)) => + let + val to = Option.map sub to + in + ((x, count, to), + (count + 1, + IM.insert (cmap, n, count))) + end) (n' + 1, IM.empty) (#constructors dt) + + val st = {count = count, + datatypes = IM.insert (#datatypes st, n, + {name = #name dt, + params = #params dt, + constructors = #constructors dt, + specializations = CM.insert (#specializations dt, + args, + {name = n', + constructors = cmap})}), + constructors = #constructors st, + decls = #decls st} + + val (cons, st) = ListUtil.foldlMap (fn ((x, n, NONE), st) => ((x, n, NONE), st) + | ((x, n, SOME t), st) => + let + val (t, st) = specCon st t + in + ((x, n, SOME t), st) + end) st cons + + val dt = (#name dt ^ "_s", + n', + [], + cons) + in + (n', cmap, {count = #count st, + datatypes = #datatypes st, + constructors = #constructors st, + decls = dt :: #decls st}) + end + 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 + +and specCon st = U.Con.foldMap {kind = kind, con = con} st + +fun pat (p, st) = + case #1 p of + PVar _ => (p, st) + | PPrim _ => (p, st) + | PCon (dk, PConVar pn, args as (_ :: _), po) => + let + val (po, st) = + case po of + NONE => (NONE, st) + | SOME p => + let + val (p, st) = pat (p, st) + in + (SOME p, st) + end + val p = (PCon (dk, PConVar pn, args, po), #2 p) + in + if List.exists isOpen args then + (p, st) + else + case IM.find (#constructors st, pn) of + NONE => (p, st) + | SOME n => + case IM.find (#datatypes st, n) of + NONE => (p, st) + | SOME dt => + let + val (n, cmap, st) = considerSpecialization (st, n, args, dt) + in + case IM.find (cmap, pn) of + NONE => raise Fail "Specialize: Missing datatype constructor (pat)" + | SOME pn' => ((PCon (dk, PConVar pn', [], po), #2 p), st) + end + end + | PCon (dk, pc, args, SOME p') => + let + val (p', st) = pat (p', st) + in + ((PCon (dk, pc, args, SOME p'), #2 p), st) + end + | PCon _ => (p, st) + | PRecord xps => + let + val (xps, st) = ListUtil.foldlMap (fn ((x, p, t), st) => + let + val (p, st) = pat (p, st) + in + ((x, p, t), st) + end) + st xps + in + ((PRecord xps, #2 p), st) + end + +fun exp (e, st) = + case e of + ECon (dk, PConVar pn, args as (_ :: _), eo) => + if List.exists isOpen args then + (e, st) + else + (case IM.find (#constructors st, pn) of + NONE => (e, st) + | SOME n => + case IM.find (#datatypes st, n) of + NONE => (e, st) + | SOME dt => + let + val (n, cmap, st) = considerSpecialization (st, n, args, dt) + in + case IM.find (cmap, pn) of + NONE => raise Fail "Specialize: Missing datatype constructor" + | SOME pn' => (ECon (dk, PConVar pn', [], eo), st) + end) + | ECase (e, pes, r) => + let + val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) => + let + val (p, st) = pat (p, st) + in + ((p, e), st) + end) st pes + in + (ECase (e, pes, r), st) + end + | _ => (e, st) + +fun decl (d, st) = (d, st) + +val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} + +fun specialize file = + let + fun doDecl (d, st) = + let + (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*) + val (d, st) = specDecl st d + 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)) + cs xnts) + (#constructors st) dts, + decls = []}) + | _ => + (case #decls st of + [] => [d] + | dts => [(DDatatype dts, #2 d), d], + {count = #count st, + datatypes = #datatypes st, + constructors = #constructors st, + decls = []}) + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {count = U.File.maxName file + 1, + datatypes = IM.empty, + constructors = IM.empty, + decls = []} file + in + ds + end + +end diff --git a/src/sql.sig b/src/sql.sig new file mode 100644 index 0000000..317c157 --- /dev/null +++ b/src/sql.sig @@ -0,0 +1,104 @@ +signature SQL = sig + +val debug : bool ref + +val sqlcacheMode : bool ref + +datatype chunk = + String of string + | Exp of Mono.exp + +val chunkify : Mono.exp -> chunk list + +type lvar = int + +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of func * exp list + | Recd of (string * exp) list + | Proj of exp * string + +datatype cmp = + Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + +datatype prop = + True + | False + | Unknown + | Lop of lop * prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +type 'a parser + +val parse : 'a parser -> Mono.exp -> 'a option + +datatype Rel = + RCmp of cmp + | RLop of lop + +datatype sqexp = + SqConst of Prim.t + | SqTrue + | SqFalse + | SqNot of sqexp + | Field of string * string + | Computed of string + | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp + | SqFunc of string * sqexp + | Unmodeled + | Null + +datatype ('a,'b) sum = inl of 'a | inr of 'b + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +datatype jtype = Inner | Left | Right | Full + +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} + | Union of query * query + +val query : query parser + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +val dml : dml parser + +end diff --git a/src/sql.sml b/src/sql.sml new file mode 100644 index 0000000..409e205 --- /dev/null +++ b/src/sql.sml @@ -0,0 +1,509 @@ +structure Sql :> SQL = struct + +open Mono + +val debug = ref false + +type lvar = int + +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of func * exp list + | Recd of (string * exp) list + | Proj of exp * string + +datatype cmp = + Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Cmp of cmp + +datatype lop = + And + | Or + +datatype prop = + True + | False + | Unknown + | Lop of lop * prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +datatype chunk = + String of string + | Exp of Mono.exp + +fun chunkify e = + case #1 e of + EPrim (Prim.String (_, s)) => [String s] + | EStrcat (e1, e2) => + let + val chs1 = chunkify e1 + val chs2 = chunkify e2 + in + case chs2 of + String s2 :: chs2' => + (case List.last chs1 of + String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2' + | _ => chs1 @ chs2) + | _ => chs1 @ chs2 + end + | _ => [Exp e] + +type 'a parser = chunk list -> ('a * chunk list) option + +fun always v chs = SOME (v, chs) + +fun parse p s = + case p (chunkify s) of + SOME (v, []) => SOME v + | _ => NONE + +fun const s chs = + case chs of + String s' :: chs => if String.isPrefix s s' then + SOME ((), if size s = size s' then + chs + else + String (String.extract (s', size s, NONE)) :: chs) + else + NONE + | _ => NONE + +fun follow p1 p2 chs = + case p1 chs of + NONE => NONE + | SOME (v1, chs) => + case p2 chs of + NONE => NONE + | SOME (v2, chs) => SOME ((v1, v2), chs) + +fun wrap p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => SOME (f v, chs) + +fun wrapP p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => + case f v of + NONE => NONE + | SOME r => SOME (r, chs) + +fun alt p1 p2 chs = + case p1 chs of + NONE => p2 chs + | v => v + +fun altL ps = + case rev ps of + [] => (fn _ => NONE) + | p :: ps => + foldl (fn (p1, p2) => alt p1 p2) p ps + +fun opt p chs = + case p chs of + NONE => SOME (NONE, chs) + | SOME (v, chs) => SOME (SOME v, chs) + +fun skip cp chs = + case chs of + String "" :: chs => skip cp chs + | String s :: chs' => if cp (String.sub (s, 0)) then + skip cp (String (String.extract (s, 1, NONE)) :: chs') + else + SOME ((), chs) + | _ => SOME ((), chs) + +fun keep cp chs = + case chs of + String "" :: chs => keep cp chs + | String s :: chs' => + let + val (befor, after) = Substring.splitl cp (Substring.full s) + in + if Substring.isEmpty befor then + NONE + else + SOME (Substring.string befor, + if Substring.isEmpty after then + chs' + else + String (Substring.string after) :: chs') + end + | _ => NONE + +(* Used by primSqlcache. *) +fun optConst s chs = + case chs of + String s' :: chs => if String.isPrefix s s' then + SOME (s, if size s = size s' then + chs + else + String (String.extract (s', size s, NONE)) :: chs) + else + SOME ("", String s' :: chs) + | _ => NONE + +fun ws p = wrap (follow (skip (fn ch => ch = #" ")) + (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) + +fun log name p chs = + (if !debug then + (print (name ^ ": "); + app (fn String s => print s + | _ => print "???") chs; + print "\n") + else + (); + p chs) + +fun list p chs = + altL [wrap (follow p (follow (ws (const ",")) (list p))) + (fn (v, ((), ls)) => v :: ls), + wrap (ws p) (fn v => [v]), + always []] chs + +val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") + +val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then + SOME (String.extract (s, 2, NONE)) + else + NONE) +val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then + SOME (str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE)) + else + SOME s) + +val field = wrap (follow (opt (follow t_ident (const "."))) + uw_ident) + (fn (SOME (t, ()), f) => (t, f) + | (NONE, f) => ("T", f)) (* Should probably deal with this MySQL/SQLite case better some day. *) + +datatype Rel = + RCmp of cmp + | RLop of lop + +datatype sqexp = + SqConst of Prim.t + | SqTrue + | SqFalse + | SqNot of sqexp + | Field of string * string + | Computed of string + | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp + | SqFunc of string * sqexp + | Unmodeled + | Null + +fun cmp s r = wrap (const s) (fn () => RCmp r) + +val sqbrel = altL [cmp "=" Eq, + cmp "IS NOT DISTINCT FROM" Eq, + cmp "<>" Ne, + cmp "<=" Le, + cmp "<" Lt, + cmp ">=" Ge, + cmp ">" Gt, + wrap (const "AND") (fn () => RLop And), + wrap (const "OR") (fn () => RLop Or)] + +datatype ('a, 'b) sum = inl of 'a | inr of 'b + +fun string chs = + case chs of + String s :: chs => + if size s >= 2 andalso String.sub (s, 0) = #"'" then + let + fun loop (cs, acc) = + case cs of + [] => NONE + | c :: cs => + if c = #"'" then + SOME (String.implode (rev acc), cs) + else if c = #"\\" then + case cs of + c :: cs => loop (cs, c :: acc) + | _ => raise Fail "Iflow.string: Unmatched backslash escape" + else + loop (cs, c :: acc) + in + case loop (String.explode (String.extract (s, 1, NONE)), []) of + NONE => NONE + | SOME (s, []) => SOME (s, chs) + | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs) + end + else + NONE + | _ => NONE + +val prim = + altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) + (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y)))) + (opt (const "::float8"))) #1, + wrap (follow (wrapP (keep Char.isDigit) + (Option.map Prim.Int o Int64.fromString)) + (opt (const "::int8"))) #1, + wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) + ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)] + +val primSqlcache = + (* Like [prim], but always uses [Prim.String]s. *) + let + fun wrapS p f = wrap p ((fn s => Prim.String (Prim.Normal, s)) o f) + in + altL [wrapS (follow (wrap (follow (keep Char.isDigit) + (follow (const ".") (keep Char.isDigit))) + (fn (x, ((), y)) => x ^ "." ^ y)) + (optConst "::float8")) + op^, + wrapS (follow (keep Char.isDigit) + (optConst "::int8")) + op^, + wrapS (follow (optConst "E") (follow string (optConst "::text"))) + (fn (c1, (s, c2)) => c1 ^ s ^ c2)] +end + +fun known' chs = + case chs of + Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs) + | _ => NONE + +fun sqlify chs = + case chs of + Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME (e, chs) + else + NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => + SOME (e, chs) + + | _ => NONE + +(* For sqlcache, we only care that we can do string equality on injected Mono + expressions, so accept any expression without modifying it. *) +val sqlifySqlcache = + fn Exp e :: chs => SOME (e, chs) + | _ => NONE + +fun constK s = wrap (const s) (fn () => s) + +val funcName = altL [constK "COUNT", + constK "MIN", + constK "MAX", + constK "SUM", + constK "AVG"] + +fun arithmetic pExp = follow (const "(") + (follow pExp + (follow (altL (map const [" + ", " - ", " * ", " / ", " >> ", " << "])) + (follow pExp (const ")")))) + +val unmodeled = altL [const "COUNT(*)", + const "CURRENT_TIMESTAMP"] + +val sqlcacheMode = ref false; + +fun sqexp chs = + log "sqexp" + (altL [wrap (if !sqlcacheMode then primSqlcache else prim) SqConst, + wrap (const "TRUE") (fn () => SqTrue), + wrap (const "FALSE") (fn () => SqFalse), + wrap (follow (const "NULL::") ident) (fn ((), _) => Null), + wrap (const "NULL") (fn () => Null), + wrap known SqKnown, + wrap func SqFunc, + wrap field Field, + wrap uw_ident Computed, + wrap (arithmetic sqexp) (fn _ => Unmodeled), + wrap unmodeled (fn () => Unmodeled), + wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, + wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") + (follow (keep (fn ch => ch <> #")")) (const ")"))))) + (fn ((), (e, _)) => e), + wrap (follow (const "(NOT ") (follow sqexp (const ")"))) + (fn ((), (e, _)) => SqNot e), + wrap (follow (ws (const "(")) + (follow (wrap + (follow sqexp + (alt + (wrap + (follow (ws sqbrel) + (ws sqexp)) + inl) + (always (inr ())))) + (fn (e1, sm) => + case sm of + inl (bo, e2) => Binop (bo, e1, e2) + | inr () => e1)) + (const ")"))) + (fn ((), (e, ())) => e)]) + chs + +and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) + (fn ((), ((), (e, ()))) => e) chs + +and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) + (fn (f, ((), (e, ()))) => (f, e)) chs + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident)) + (fn (e, ((), s)) => SqExp (e, s))) + (wrap field SqField) + +val select = log "select" + (wrap (follow (const "SELECT ") (list sitem)) + (fn ((), ls) => ls)) + +datatype jtype = Inner | Left | Right | Full + +datatype fitem = + Table of string * string (* table AS name *) + | Join of jtype * fitem * fitem * sqexp + | Nested of query * string (* query AS name *) + + and query = + Query1 of {Select : sitem list, From : fitem list, Where : sqexp option} + | Union of query * query + +val wher = wrap (follow (ws (const "WHERE ")) sqexp) + (fn ((), ls) => ls) + +val orderby = log "orderby" + (wrap (follow (ws (const "ORDER BY ")) + (list (follow sqexp + (opt (ws (const "DESC")))))) + ignore) + +val groupby = log "groupby" + (wrap (follow (ws (const "GROUP BY ")) + (list sqexp)) + ignore) + +val jtype = altL [wrap (const "JOIN") (fn () => Inner), + wrap (const "LEFT JOIN") (fn () => Left), + wrap (const "RIGHT JOIN") (fn () => Right), + wrap (const "FULL JOIN") (fn () => Full)] + +fun fitem chs = altL [wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => Table (t, f)), + wrap (follow (const "(") + (follow fitem + (follow (ws jtype) + (follow fitem + (follow (const " ON ") + (follow sqexp + (const ")"))))))) + (fn ((), (fi1, (jt, (fi2, ((), (se, ())))))) => + Join (jt, fi1, fi2, se)), + wrap (follow (const "(") + (follow query + (follow (const ") AS ") t_ident))) + (fn ((), (q, ((), f))) => Nested (q, f))] + chs + +and query1 chs = log "query1" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) + chs + +and from chs = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) + chs + +and query chs = log "query" + (wrap (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (follow (opt groupby) (opt orderby))) + #1) + chs + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +val insert = log "insert" + (wrapP (follow (const "INSERT INTO ") + (follow uw_ident + (follow (const " (") + (follow (list uw_ident) + (follow (const ") VALUES (") + (follow (list sqexp) + (const ")"))))))) + (fn ((), (tab, ((), (fs, ((), (es, ())))))) => + (SOME (tab, ListPair.zipEq (fs, es))) + handle ListPair.UnequalLengths => NONE)) + +val delete = log "delete" + (wrap (follow (const "DELETE FROM ") + (follow uw_ident + (follow (opt (const " AS T_T")) + (opt (follow (const " WHERE ") sqexp))))) + (fn ((), (tab, (_, wher))) => (tab, case wher of + SOME (_, es) => es + | NONE => SqTrue))) + +val setting = log "setting" + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) + +val update = log "update" + (wrap (follow (const "UPDATE ") + (follow uw_ident + (follow (follow (opt (const " AS T_T")) (const " SET ")) + (follow (list setting) + (follow (ws (const "WHERE ")) + sqexp))))) + (fn ((), (tab, (_, (fs, ((), e))))) => + (tab, fs, e))) + +val dml = log "dml" + (altL [wrap insert Insert, + wrap delete Delete, + wrap update Update]) + +datatype querydml = + Query of query + | Dml of dml + +val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query]) + +end diff --git a/src/sqlcache.sig b/src/sqlcache.sig new file mode 100644 index 0000000..e264c1f --- /dev/null +++ b/src/sqlcache.sig @@ -0,0 +1,11 @@ +signature SQLCACHE = sig + +val setCache : Cache.cache -> unit +val getCache : unit -> Cache.cache + +val setHeuristic : string -> unit + +val getFfiInfo : unit -> {index : int, params : int} list +val go : Mono.file -> Mono.file + +end diff --git a/src/sqlcache.sml b/src/sqlcache.sml new file mode 100644 index 0000000..83a264f --- /dev/null +++ b/src/sqlcache.sml @@ -0,0 +1,1732 @@ +structure Sqlcache :> SQLCACHE = struct + + +(*********************) +(* General Utilities *) +(*********************) + +structure IK = struct type ord_key = int val compare = Int.compare end +structure IS = IntBinarySet +structure IM = IntBinaryMap +structure SK = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure IIMM = MultimapFn(structure KeyMap = IM structure ValSet = IS) +structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) + +fun id x = x + +fun iterate f n x = if n < 0 + then raise Fail "Can't iterate function negative number of times." + else if n = 0 + then x + else iterate f (n-1) (f x) + +(* From the MLton wiki. *) +infix 3 <\ fun x <\ f = fn y => f (x, y) (* Left section *) +infix 3 \> fun f \> y = f y (* Left application *) + +fun mapFst f (x, y) = (f x, y) + +(* Option monad. *) +fun obind (x, f) = Option.mapPartial f x +fun oguard (b, x) = if b then x () else NONE +fun omap f = fn SOME x => SOME (f x) | _ => NONE +fun omap2 f = fn (SOME x, SOME y) => SOME (f (x,y)) | _ => NONE +fun osequence ys = List.foldr (omap2 op::) (SOME []) ys + +fun concatMap f xs = List.concat (map f xs) + +val rec cartesianProduct : 'a list list -> 'a list list = + fn [] => [[]] + | (xs :: xss) => concatMap (fn ys => concatMap (fn x => [x :: ys]) xs) + (cartesianProduct xss) + +fun indexOf test = + let + fun f n = + fn [] => NONE + | (x::xs) => if test x then SOME n else f (n+1) xs + in + f 0 + end + + +(************) +(* Settings *) +(************) + +open Mono + +(* Filled in by [addFlushing]. *) +val ffiInfoRef : {index : int, params : int} list ref = ref [] + +fun resetFfiInfo () = ffiInfoRef := [] + +fun getFfiInfo () = !ffiInfoRef + +(* Some FFIs have writing as their only effect, which the caching records. *) +val ffiEffectful = + (* ASK: how can this be less hard-coded? *) + let + val okayWrites = SS.fromList ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w", + "urlifyChannel_w"] + in + (* ASK: is it okay to hardcode Sqlcache functions as effectful? *) + fn (m, f) => Settings.isEffectful (m, f) + andalso not (m = "Basis" andalso SS.member (okayWrites, f)) + end + +val cacheRef = ref LruCache.cache +fun setCache c = cacheRef := c +fun getCache () = !cacheRef + +datatype heuristic = Smart | Always | Never | NoPureAll | NoPureOne | NoCombo + +val heuristicRef = ref NoPureOne +fun setHeuristic h = heuristicRef := (case h of + "smart" => Smart + | "always" => Always + | "never" => Never + | "nopureall" => NoPureAll + | "nopureone" => NoPureOne + | "nocombo" => NoCombo + | _ => raise Fail "Sqlcache: setHeuristic") +fun getHeuristic () = !heuristicRef + + +(************************) +(* Really Useful Things *) +(************************) + +(* Used to have type context for local variables in MonoUtil functions. *) +val doBind = + fn (env, MonoUtil.Exp.RelE (x, t)) => MonoEnv.pushERel env x t NONE + | (env, MonoUtil.Exp.NamedE (x, n, t, eo, s)) => MonoEnv.pushENamed env x n t eo s + | (env, MonoUtil.Exp.Datatype (x, n, cs)) => MonoEnv.pushDatatype env x n cs + +val dummyLoc = ErrorMsg.dummySpan + +(* DEBUG *) +fun printExp msg exp = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_exp MonoEnv.empty exp); exp) +fun printExp' msg exp' = (printExp msg (exp', dummyLoc); exp') +fun printTyp msg typ = + (Print.preface ("SQLCACHE: " ^ msg ^ ":", MonoPrint.p_typ MonoEnv.empty typ); typ) +fun printTyp' msg typ' = (printTyp msg (typ', dummyLoc); typ') +fun obindDebug printer (x, f) = + case x of + NONE => NONE + | SOME x' => case f x' of + NONE => (printer (); NONE) + | y => y + + +(*******************) +(* Effect Analysis *) +(*******************) + +(* TODO: test this. *) +fun transitiveAnalysis doVal state (decls, _) = + let + val doDecl = + fn ((DVal v, _), state) => doVal (v, state) + (* Pass over the list of values a number of times equal to its size, + making sure whatever property we're testing propagates everywhere + it should. This is analagous to the Bellman-Ford algorithm. *) + | ((DValRec vs, _), state) => + iterate (fn state => List.foldl doVal state vs) (length vs) state + | (_, state) => state + in + List.foldl doDecl state decls + end + +(* Makes an exception for [EWrite] (which is recorded when caching). *) +fun effectful (effs : IS.set) = + let + val isFunction = + fn (TFun _, _) => true + | _ => false + fun doExp (env, e) = + case e of + EPrim _ => false + (* For now: variables of function type might be effectful, but + others are fully evaluated and are therefore not effectful. *) + | ERel n => isFunction (#2 (MonoEnv.lookupERel env n)) + | ENamed n => IS.member (effs, n) + | EFfi (m, f) => ffiEffectful (m, f) + | EFfiApp (m, f, _) => ffiEffectful (m, f) + (* These aren't effectful unless a subexpression is. *) + | ECon _ => false + | ENone _ => false + | ESome _ => false + | EApp _ => false + | EAbs _ => false + | EUnop _ => false + | EBinop _ => false + | ERecord _ => false + | EField _ => false + | ECase _ => false + | EStrcat _ => false + (* EWrite is a special exception because we record writes when caching. *) + | EWrite _ => false + | ESeq _ => false + | ELet _ => false + | EUnurlify _ => false + (* ASK: what should we do about closures? *) + (* Everything else is some sort of effect. We could flip this and + explicitly list bits of Mono that are effectful, but this is + conservatively robust to future changes (however unlikely). *) + | _ => true + in + MonoUtil.Exp.existsB {typ = fn _ => false, exp = doExp, bind = doBind} + end + +(* TODO: test this. *) +fun effectfulDecls file = + transitiveAnalysis (fn ((_, name, _, e, _), effs) => + if effectful effs MonoEnv.empty e + then IS.add (effs, name) + else effs) + IS.empty + file + + +(*********************************) +(* Boolean Formula Normalization *) +(*********************************) + +datatype junctionType = Conj | Disj + +datatype 'atom formula = + Atom of 'atom + | Negate of 'atom formula + | Combo of junctionType * 'atom formula list + +(* Guaranteed to have all negation pushed to the atoms. *) +datatype 'atom formula' = + Atom' of 'atom + | Combo' of junctionType * 'atom formula' list + +val flipJt = fn Conj => Disj | Disj => Conj + +(* Pushes all negation to the atoms.*) +fun pushNegate (normalizeAtom : bool * 'atom -> 'atom) (negating : bool) = + fn Atom x => Atom' (normalizeAtom (negating, x)) + | Negate f => pushNegate normalizeAtom (not negating) f + | Combo (j, fs) => Combo' (if negating then flipJt j else j, + map (pushNegate normalizeAtom negating) fs) + +val rec flatten = + fn Combo' (_, [f]) => flatten f + | Combo' (j, fs) => + Combo' (j, List.foldr (fn (f, acc) => + case f of + Combo' (j', fs') => + if j = j' orelse length fs' = 1 + then fs' @ acc + else f :: acc + | _ => f :: acc) + [] + (map flatten fs)) + | f => f + +(* [simplify] operates on the desired normal form. E.g., if [junc] is [Disj], + consider the list of lists to be a disjunction of conjunctions. *) +fun normalize' (simplify : 'a list list -> 'a list list) + (junc : junctionType) = + let + fun norm junc = + simplify + o (fn Atom' x => [[x]] + | Combo' (j, fs) => + let + val fss = map (norm junc) fs + in + if j = junc + then List.concat fss + else map List.concat (cartesianProduct fss) + end) + in + norm junc + end + +fun normalize simplify normalizeAtom junc = + normalize' simplify junc + o flatten + o pushNegate normalizeAtom false + +fun mapFormula mf = + fn Atom x => Atom (mf x) + | Negate f => Negate (mapFormula mf f) + | Combo (j, fs) => Combo (j, map (mapFormula mf) fs) + +fun mapFormulaExps mf = mapFormula (fn (cmp, e1, e2) => (cmp, mf e1, mf e2)) + + +(****************) +(* SQL Analysis *) +(****************) + +structure CmpKey = struct + + type ord_key = Sql.cmp + + val compare = + fn (Sql.Eq, Sql.Eq) => EQUAL + | (Sql.Eq, _) => LESS + | (_, Sql.Eq) => GREATER + | (Sql.Ne, Sql.Ne) => EQUAL + | (Sql.Ne, _) => LESS + | (_, Sql.Ne) => GREATER + | (Sql.Lt, Sql.Lt) => EQUAL + | (Sql.Lt, _) => LESS + | (_, Sql.Lt) => GREATER + | (Sql.Le, Sql.Le) => EQUAL + | (Sql.Le, _) => LESS + | (_, Sql.Le) => GREATER + | (Sql.Gt, Sql.Gt) => EQUAL + | (Sql.Gt, _) => LESS + | (_, Sql.Gt) => GREATER + | (Sql.Ge, Sql.Ge) => EQUAL + +end + +val rec chooseTwos : 'a list -> ('a * 'a) list = + fn [] => [] + | x :: ys => map (fn y => (x, y)) ys @ chooseTwos ys + +fun removeRedundant madeRedundantBy zs = + let + fun removeRedundant' (xs, ys) = + case xs of + [] => ys + | x :: xs' => + removeRedundant' (xs', + if List.exists (fn y => madeRedundantBy (x, y)) (xs' @ ys) + then ys + else x :: ys) + in + removeRedundant' (zs, []) + end + +datatype atomExp = + True + | False + | QueryArg of int + | DmlRel of int + | Prim of Prim.t + | Field of string * string + +structure AtomExpKey : ORD_KEY = struct + + type ord_key = atomExp + + val compare = + fn (True, True) => EQUAL + | (True, _) => LESS + | (_, True) => GREATER + | (False, False) => EQUAL + | (False, _) => LESS + | (_, False) => GREATER + | (QueryArg n1, QueryArg n2) => Int.compare (n1, n2) + | (QueryArg _, _) => LESS + | (_, QueryArg _) => GREATER + | (DmlRel n1, DmlRel n2) => Int.compare (n1, n2) + | (DmlRel _, _) => LESS + | (_, DmlRel _) => GREATER + | (Prim p1, Prim p2) => Prim.compare (p1, p2) + | (Prim _, _) => LESS + | (_, Prim _) => GREATER + | (Field (t1, f1), Field (t2, f2)) => + case String.compare (t1, t2) of + EQUAL => String.compare (f1, f2) + | ord => ord + +end + +structure AtomOptionKey = OptionKeyFn(AtomExpKey) + +val rec tablesOfQuery = + fn Sql.Query1 {From = fitems, ...} => List.foldl SS.union SS.empty (map tableOfFitem fitems) + | Sql.Union (q1, q2) => SS.union (tablesOfQuery q1, tablesOfQuery q2) +and tableOfFitem = + fn Sql.Table (t, _) => SS.singleton t + | Sql.Nested (q, _) => tablesOfQuery q + | Sql.Join (_, f1, f2, _) => SS.union (tableOfFitem f1, tableOfFitem f2) + +val tableOfDml = + fn Sql.Insert (tab, _) => tab + | Sql.Delete (tab, _) => tab + | Sql.Update (tab, _, _) => tab + +val freeVars = + MonoUtil.Exp.foldB + {typ = #2, + exp = fn (bound, ERel n, vars) => if n < bound + then vars + else IS.add (vars, n - bound) + | (_, _, vars) => vars, + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + 0 + IS.empty + +(* A path is a number of field projections of a variable. *) +type path = int * string list +structure PK = PairKeyFn(structure I = IK structure J = ListKeyFn(SK)) +structure PS = BinarySetFn(PK) + +val pathOfExp = + let + fun readFields acc exp = + acc + <\obind\> + (fn fs => + case #1 exp of + ERel n => SOME (n, fs) + | EField (exp, f) => readFields (SOME (f::fs)) exp + | _ => NONE) + in + readFields (SOME []) + end + +fun expOfPath (n, fs) = + List.foldl (fn (f, exp) => (EField (exp, f), dummyLoc)) (ERel n, dummyLoc) fs + +fun freePaths'' bound exp paths = + case pathOfExp (exp, dummyLoc) of + NONE => paths + | SOME (n, fs) => if n < bound then paths else PS.add (paths, (n - bound, fs)) + +(* ASK: nicer way? :( *) +fun freePaths' bound exp = + case #1 exp of + EPrim _ => id + | e as ERel _ => freePaths'' bound e + | ENamed _ => id + | ECon (_, _, data) => (case data of NONE => id | SOME e => freePaths' bound e) + | ENone _ => id + | ESome (_, e) => freePaths' bound e + | EFfi _ => id + | EFfiApp (_, _, args) => + List.foldl (fn ((e, _), acc) => freePaths' bound e o acc) id args + | EApp (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EAbs (_, _, _, e) => freePaths' (bound + 1) e + | EUnop (_, e) => freePaths' bound e + | EBinop (_, _, e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ERecord fields => List.foldl (fn ((_, e, _), acc) => freePaths' bound e o acc) id fields + | e as EField _ => freePaths'' bound e + | ECase (e, cases, _) => + List.foldl (fn ((p, e), acc) => freePaths' (MonoEnv.patBindsN p + bound) e o acc) + (freePaths' bound e) + cases + | EStrcat (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EError (e, _) => freePaths' bound e + | EReturnBlob {blob, mimeType = e, ...} => + freePaths' bound e o (case blob of NONE => id | SOME e => freePaths' bound e) + | ERedirect (e, _) => freePaths' bound e + | EWrite e => freePaths' bound e + | ESeq (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ELet (_, _, e1, e2) => freePaths' bound e1 o freePaths' (bound + 1) e2 + | EClosure (_, es) => List.foldl (fn (e, acc) => freePaths' bound e o acc) id es + | EQuery {query = e1, body = e2, initial = e3, ...} => + freePaths' bound e1 o freePaths' (bound + 2) e2 o freePaths' bound e3 + | EDml (e, _) => freePaths' bound e + | ENextval e => freePaths' bound e + | ESetval (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | EUnurlify (e, _, _) => freePaths' bound e + | EJavaScript (_, e) => freePaths' bound e + | ESignalReturn e => freePaths' bound e + | ESignalBind (e1, e2) => freePaths' bound e1 o freePaths' bound e2 + | ESignalSource e => freePaths' bound e + | EServerCall (e, _, _, _) => freePaths' bound e + | ERecv (e, _) => freePaths' bound e + | ESleep e => freePaths' bound e + | ESpawn e => freePaths' bound e + +fun freePaths exp = freePaths' 0 exp PS.empty + +datatype unbind = Known of exp | Unknowns of int + +datatype cacheArg = AsIs of exp | Urlify of exp + +structure InvalInfo :> sig + type t + type state = {tableToIndices : SIMM.multimap, + indexToInvalInfo : (t * int) IntBinaryMap.map, + ffiInfo : {index : int, params : int} list, + index : int} + val empty : t + val singleton : Sql.query -> t + val query : t -> Sql.query + val orderArgs : t * Mono.exp -> cacheArg list option + val unbind : t * unbind -> t option + val union : t * t -> t + val updateState : t * int * state -> state +end = struct + + (* Variable, field projections, possible wrapped sqlification FFI call. *) + type sqlArg = path * (string * string * typ) option + + type subst = sqlArg IM.map + + (* TODO: store free variables as well? *) + type t = (Sql.query * subst) list + + type state = {tableToIndices : SIMM.multimap, + indexToInvalInfo : (t * int) IntBinaryMap.map, + ffiInfo : {index : int, params : int} list, + index : int} + + structure AK = PairKeyFn( + structure I = PK + structure J = OptionKeyFn(TripleKeyFn( + structure I = SK + structure J = SK + structure K = struct type ord_key = Mono.typ val compare = MonoUtil.Typ.compare end))) + structure AS = BinarySetFn(AK) + structure AM = BinaryMapFn(AK) + + (* Traversal Utilities *) + (* TODO: get rid of unused ones. *) + + (* Need lift', etc. because we don't have rank-2 polymorphism. This should + probably use a functor (an ML one, not Haskell) but works for now. *) + fun traverseSqexp (pure, _, _, _, lift, lift', _, _, lift2, _, _, _, _, _) f = + let + val rec tr = + fn Sql.SqNot se => lift Sql.SqNot (tr se) + | Sql.Binop (r, se1, se2) => + lift2 (fn (trse1, trse2) => Sql.Binop (r, trse1, trse2)) (tr se1, tr se2) + | Sql.SqKnown se => lift Sql.SqKnown (tr se) + | Sql.Inj (e', loc) => lift' (fn fe' => Sql.Inj (fe', loc)) (f e') + | Sql.SqFunc (s, se) => lift (fn trse => Sql.SqFunc (s, trse)) (tr se) + | se => pure se + in + tr + end + + fun traverseFitem (ops as (_, _, _, pure''', _, _, _, lift''', _, _, _, _, lift2'''', lift2''''')) f = + let + val rec tr = + fn Sql.Table t => pure''' (Sql.Table t) + | Sql.Join (jt, fi1, fi2, se) => + lift2'''' (fn ((trfi1, trfi2), trse) => Sql.Join (jt, trfi1, trfi2, trse)) + (lift2''''' id (tr fi1, tr fi2), traverseSqexp ops f se) + | Sql.Nested (q, s) => lift''' (fn trq => Sql.Nested (trq, s)) + (traverseQuery ops f q) + in + tr + end + + and traverseQuery (ops as (_, pure', pure'', _, _, _, lift'', _, _, lift2', lift2'', lift2''', _, _)) f = + let + val rec seqList = + fn [] => pure'' [] + | (x::xs) => lift2''' op:: (x, seqList xs) + val rec tr = + fn Sql.Query1 q => + (* TODO: make sure we don't need to traverse [#Select q]. *) + lift2' (fn (trfrom, trwher) => Sql.Query1 {Select = #Select q, + From = trfrom, + Where = trwher}) + (seqList (map (traverseFitem ops f) (#From q)), + case #Where q of + NONE => pure' NONE + | SOME se => lift'' SOME (traverseSqexp ops f se)) + | Sql.Union (q1, q2) => lift2'' Sql.Union (tr q1, tr q2) + in + tr + end + + (* Include unused tuple elements in argument for convenience of using same + argument as [traverseQuery]. *) + fun traverseIM (pure, _, _, _, _, _, _, _, _, lift2, _, _, _, _) f = + IM.foldli (fn (k, v, acc) => lift2 (fn (acc, w) => IM.insert (acc, k, w)) (acc, f (k,v))) + (pure IM.empty) + + fun traverseSubst (ops as (_, pure', _, _, lift, _, _, _, _, lift2', _, _, _, _)) f = + let + fun mp ((n, fields), sqlify) = + lift (fn ((n', fields'), sqlify') => + let + fun wrap sq = ((n', fields' @ fields), sq) + in + case (fields', sqlify', fields, sqlify) of + (_, NONE, _, NONE) => wrap NONE + | (_, NONE, _, sq as SOME _) => wrap sq + (* Last case should suffice because we don't + project from a sqlified value (which is a + string). *) + | (_, sq as SOME _, [], NONE) => wrap sq + | _ => raise Fail "Sqlcache: traverseSubst" + end) + (f n) + in + traverseIM ops (fn (_, v) => mp v) + end + + fun monoidOps plus zero = + (fn _ => zero, fn _ => zero, fn _ => zero, fn _ => zero, + fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, fn _ => fn x => x, + fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus, fn _ => plus) + + val optionOps = (SOME, SOME, SOME, SOME, + omap, omap, omap, omap, + omap2, omap2, omap2, omap2, omap2, omap2) + + fun foldMapQuery plus zero = traverseQuery (monoidOps plus zero) + val omapQuery = traverseQuery optionOps + fun foldMapIM plus zero = traverseIM (monoidOps plus zero) + fun omapIM f = traverseIM optionOps f + fun foldMapSubst plus zero = traverseSubst (monoidOps plus zero) + fun omapSubst f = traverseSubst optionOps f + + val varsOfQuery = foldMapQuery IS.union + IS.empty + (fn e' => freeVars (e', dummyLoc)) + + fun varsOfSubst subst = foldMapSubst IS.union IS.empty IS.singleton subst + + val varsOfList = + fn [] => IS.empty + | (q::qs) => varsOfQuery (List.foldl Sql.Union q qs) + + (* Signature Implementation *) + + val empty = [] + + fun singleton q = [(q, IS.foldl (fn (n, acc) => IM.insert (acc, n, ((n, []), NONE))) + IM.empty + (varsOfQuery q))] + + val union = op@ + + fun sqlArgsSet (q, subst) = + IM.foldl AS.add' AS.empty subst + + fun sqlArgsMap (qs : t) = + let + val args = + List.foldl (fn ((q, subst), acc) => + IM.foldl (fn (arg, acc) => AM.insert (acc, arg, ())) acc subst) + AM.empty + qs + val countRef = ref (~1) + fun count () = (countRef := !countRef + 1; !countRef) + in + (* Maps each arg to a different consecutive integer, starting from 0. *) + AM.map count args + end + + fun expOfArg (path, sqlify) = + let + val exp = expOfPath path + in + case sqlify of + NONE => exp + | SOME (m, x, typ) => (EFfiApp (m, x, [(exp, typ)]), dummyLoc) + end + + fun orderArgs (qs : t, exp) = + let + val paths = freePaths exp + fun erel n = (ERel n, dummyLoc) + val argsMap = sqlArgsMap qs + val args = map (expOfArg o #1) (AM.listItemsi argsMap) + val invalPaths = List.foldl PS.union PS.empty (map freePaths args) + (* TODO: make sure these variables are okay to remove from the argument list. *) + val pureArgs = PS.difference (paths, invalPaths) + val shouldCache = + case getHeuristic () of + Smart => + (case (qs, PS.numItems pureArgs) of + ((q::qs), 0) => + let + val args = sqlArgsSet q + val argss = map sqlArgsSet qs + fun test (args, acc) = + acc + <\obind\> + (fn args' => + let + val both = AS.union (args, args') + in + (AS.numItems args = AS.numItems both + orelse AS.numItems args' = AS.numItems both) + <\oguard\> + (fn _ => SOME both) + end) + in + case List.foldl test (SOME args) argss of + NONE => false + | SOME _ => true + end + | _ => false) + | Always => true + | Never => (case qs of [_] => PS.numItems pureArgs = 0 | _ => false) + | NoPureAll => (case qs of [] => false | _ => true) + | NoPureOne => (case qs of [] => false | _ => PS.numItems pureArgs = 0) + | NoCombo => PS.numItems pureArgs = 0 orelse AM.numItems argsMap = 0 + in + (* Put arguments we might invalidate by first. *) + if shouldCache + then SOME (map AsIs args @ map (Urlify o expOfPath) (PS.listItems pureArgs)) + else NONE + end + + (* As a kludge, we rename the variables in the query to correspond to the + argument of the cache they're part of. *) + fun query (qs : t) = + let + val argsMap = sqlArgsMap qs + fun substitute subst = + fn ERel n => IM.find (subst, n) + <\obind\> + (fn arg => + AM.find (argsMap, arg) + <\obind\> + (fn n' => SOME (ERel n'))) + | _ => raise Fail "Sqlcache: query (a)" + in + case (map #1 qs) of + (q :: qs) => + let + val q = List.foldl Sql.Union q qs + val ns = IS.listItems (varsOfQuery q) + val rename = + fn ERel n => omap ERel (indexOf (fn n' => n' = n) ns) + | _ => raise Fail "Sqlcache: query (b)" + in + case omapQuery rename q of + SOME q => q + (* We should never get NONE because indexOf should never fail. *) + | NONE => raise Fail "Sqlcache: query (c)" + end + (* We should never reach this case because [updateState] won't + put anything in the state if there are no queries. *) + | [] => raise Fail "Sqlcache: query (d)" + end + + val argOfExp = + let + fun doFields acc exp = + acc + <\obind\> + (fn (fs, sqlify) => + case #1 exp of + ERel n => SOME (n, fs, sqlify) + | EField (exp, f) => doFields (SOME (f::fs, sqlify)) exp + | _ => NONE) + in + fn (EFfiApp ("Basis", x, [(exp, typ)]), _) => + if String.isPrefix "sqlify" x + then omap (fn path => (path, SOME ("Basis", x, typ))) (pathOfExp exp) + else NONE + | exp => omap (fn path => (path, NONE)) (pathOfExp exp) + end + + val unbind1 = + fn Known e => + let + val replacement = argOfExp e + in + omapSubst (fn 0 => replacement + | n => SOME ((n-1, []), NONE)) + end + | Unknowns k => omapSubst (fn n => if n < k then NONE else SOME ((n-k, []), NONE)) + + fun unbind (qs, ub) = + case ub of + (* Shortcut if nothing's changing. *) + Unknowns 0 => SOME qs + | _ => osequence (map (fn (q, subst) => unbind1 ub subst + <\obind\> + (fn subst' => SOME (q, subst'))) qs) + + fun updateState (qs, numArgs, state as {index, ...} : state) = + {tableToIndices = List.foldr (fn ((q, _), acc) => + SS.foldl (fn (tab, acc) => + SIMM.insert (acc, tab, index)) + acc + (tablesOfQuery q)) + (#tableToIndices state) + qs, + indexToInvalInfo = IM.insert (#indexToInvalInfo state, index, (qs, numArgs)), + ffiInfo = {index = index, params = numArgs} :: #ffiInfo state, + index = index + 1} + +end + +structure UF = UnionFindFn(AtomExpKey) + +val rec sqexpToFormula = + fn Sql.SqTrue => Combo (Conj, []) + | Sql.SqFalse => Combo (Disj, []) + | Sql.SqNot e => Negate (sqexpToFormula e) + | Sql.Binop (Sql.RCmp c, e1, e2) => Atom (c, e1, e2) + | Sql.Binop (Sql.RLop l, p1, p2) => Combo (case l of Sql.And => Conj | Sql.Or => Disj, + [sqexpToFormula p1, sqexpToFormula p2]) + | e as Sql.Field f => Atom (Sql.Eq, e, Sql.SqTrue) + (* ASK: any other sqexps that can be props? *) + | Sql.SqConst prim => + (case prim of + (Prim.String (Prim.Normal, s)) => + if s = #trueString (Settings.currentDbms ()) + then Combo (Conj, []) + else if s = #falseString (Settings.currentDbms ()) + then Combo (Disj, []) + else raise Fail "Sqlcache: sqexpToFormula (SqConst a)" + | _ => raise Fail "Sqlcache: sqexpToFormula (SqConst b)") + | Sql.Computed _ => raise Fail "Sqlcache: sqexpToFormula (Computed)" + | Sql.SqKnown _ => raise Fail "Sqlcache: sqexpToFormula (SqKnown)" + | Sql.Inj _ => raise Fail "Sqlcache: sqexpToFormula (Inj)" + | Sql.SqFunc _ => raise Fail "Sqlcache: sqexpToFormula (SqFunc)" + | Sql.Unmodeled => raise Fail "Sqlcache: sqexpToFormula (Unmodeled)" + | Sql.Null => raise Fail "Sqlcache: sqexpToFormula (Null)" + +fun mapSqexpFields f = + fn Sql.Field (t, v) => f (t, v) + | Sql.SqNot e => Sql.SqNot (mapSqexpFields f e) + | Sql.Binop (r, e1, e2) => Sql.Binop (r, mapSqexpFields f e1, mapSqexpFields f e2) + | Sql.SqKnown e => Sql.SqKnown (mapSqexpFields f e) + | Sql.SqFunc (s, e) => Sql.SqFunc (s, mapSqexpFields f e) + | e => e + +fun renameTables tablePairs = + let + fun rename table = + case List.find (fn (_, t) => table = t) tablePairs of + NONE => table + | SOME (realTable, _) => realTable + in + mapSqexpFields (fn (t, f) => Sql.Field (rename t, f)) + end + +structure FlattenQuery = struct + + datatype substitution = RenameTable of string | SubstituteExp of Sql.sqexp SM.map + + fun applySubst substTable = + let + fun substitute (table, field) = + case SM.find (substTable, table) of + NONE => Sql.Field (table, field) + | SOME (RenameTable realTable) => Sql.Field (realTable, field) + | SOME (SubstituteExp substField) => + case SM.find (substField, field) of + NONE => raise Fail "Sqlcache: applySubst" + | SOME se => se + in + mapSqexpFields substitute + end + + fun addToSubst (substTable, table, substField) = + SM.insert (substTable, + table, + case substField of + RenameTable _ => substField + | SubstituteExp subst => SubstituteExp (SM.map (applySubst substTable) subst)) + + fun newSubst (t, s) = addToSubst (SM.empty, t, s) + + datatype sitem' = Named of Sql.sqexp * string | Unnamed of Sql.sqexp + + type queryFlat = {Select : sitem' list, Where : Sql.sqexp} + + val sitemsToSubst = + List.foldl (fn (Named (se, s), acc) => SM.insert (acc, s, se) + | (Unnamed _, _) => raise Fail "Sqlcache: sitemsToSubst") + SM.empty + + fun unionSubst (s1, s2) = SM.unionWith (fn _ => raise Fail "Sqlcache: unionSubst") (s1, s2) + + fun sqlAnd (se1, se2) = Sql.Binop (Sql.RLop Sql.And, se1, se2) + + val rec flattenFitem : Sql.fitem -> (Sql.sqexp * substitution SM.map) list = + fn Sql.Table (real, alias) => [(Sql.SqTrue, newSubst (alias, RenameTable real))] + | Sql.Nested (q, s) => + let + val qfs = flattenQuery q + in + map (fn (qf, subst) => + (#Where qf, addToSubst (subst, s, SubstituteExp (sitemsToSubst (#Select qf))))) + qfs + end + | Sql.Join (jt, fi1, fi2, se) => + concatMap (fn ((wher1, subst1)) => + map (fn (wher2, subst2) => + let + val subst = unionSubst (subst1, subst2) + in + (* ON clause becomes part of the accumulated WHERE. *) + (sqlAnd (sqlAnd (wher1, wher2), applySubst subst se), subst) + end) + (flattenFitem fi2)) + (flattenFitem fi1) + + and flattenQuery : Sql.query -> (queryFlat * substitution SM.map) list = + fn Sql.Query1 q => + let + val fifss = cartesianProduct (map flattenFitem (#From q)) + in + map (fn fifs => + let + val subst = List.foldl (fn ((_, subst), acc) => unionSubst (acc, subst)) + SM.empty + fifs + val wher = List.foldr (fn ((wher, _), acc) => sqlAnd (wher, acc)) + (case #Where q of + NONE => Sql.SqTrue + | SOME wher => wher) + fifs + in + (* ASK: do we actually need to pass the substitution through here? *) + (* We use the substitution later, but it's not clear we + need any of its currently present fields again. *) + ({Select = map (fn Sql.SqExp (se, s) => Named (applySubst subst se, s) + | Sql.SqField tf => + Unnamed (applySubst subst (Sql.Field tf))) + (#Select q), + Where = applySubst subst wher}, + subst) + end) + fifss + end + | Sql.Union (q1, q2) => (flattenQuery q1) @ (flattenQuery q2) + +end + +val flattenQuery = map #1 o FlattenQuery.flattenQuery + +fun queryFlatToFormula marker {Select = sitems, Where = wher} = + let + val fWhere = sqexpToFormula wher + in + case marker of + NONE => fWhere + | SOME markFields => + let + val fWhereMarked = mapFormulaExps markFields fWhere + val toSqexp = + fn FlattenQuery.Named (se, _) => se + | FlattenQuery.Unnamed se => se + fun ineq se = Atom (Sql.Ne, se, markFields se) + val fIneqs = Combo (Disj, map (ineq o toSqexp) sitems) + in + (Combo (Conj, + [fWhere, + Combo (Disj, + [Negate fWhereMarked, + Combo (Conj, [fWhereMarked, fIneqs])])])) + end + end + +fun queryToFormula marker q = Combo (Disj, map (queryFlatToFormula marker) (flattenQuery q)) + +fun valsToFormula (markLeft, markRight) (table, vals) = + Combo (Conj, + map (fn (field, v) => Atom (Sql.Eq, markLeft (Sql.Field (table, field)), markRight v)) + vals) + +(* TODO: verify logic for insertion and deletion. *) +val rec dmlToFormulaMarker = + fn Sql.Insert (table, vals) => (valsToFormula (id, id) (table, vals), NONE) + | Sql.Delete (table, wher) => (sqexpToFormula (renameTables [(table, "T")] wher), NONE) + | Sql.Update (table, vals, wher) => + let + val fWhere = sqexpToFormula (renameTables [(table, "T")] wher) + fun fVals marks = valsToFormula marks (table, vals) + val modifiedFields = SS.addList (SS.empty, map #1 vals) + (* TODO: don't use field name hack. *) + val markFields = + mapSqexpFields (fn (t, v) => if t = table andalso SS.member (modifiedFields, v) + then Sql.Field (t, v ^ "'") + else Sql.Field (t, v)) + val mark = mapFormulaExps markFields + in + ((Combo (Disj, [Combo (Conj, [fVals (id, markFields), mark fWhere]), + Combo (Conj, [fVals (markFields, id), fWhere])])), + SOME markFields) + end + +fun pairToFormulas (query, dml) = + let + val (fDml, marker) = dmlToFormulaMarker dml + in + (queryToFormula marker query, fDml) + end + +structure ConflictMaps = struct + + structure TK = TripleKeyFn(structure I = CmpKey + structure J = AtomOptionKey + structure K = AtomOptionKey) + + structure TS : ORD_SET = BinarySetFn(TK) + + val toKnownEquality = + (* [NONE] here means unkown. Anything that isn't a comparison between two + knowns shouldn't be used, and simply dropping unused terms is okay in + disjunctive normal form. *) + fn (Sql.Eq, SOME e1, SOME e2) => SOME (e1, e2) + | _ => NONE + + fun equivClasses atoms : atomExp list list option = + let + val uf = List.foldl UF.union' UF.empty (List.mapPartial toKnownEquality atoms) + val contradiction = + fn (cmp, SOME ae1, SOME ae2) => (cmp = Sql.Ne orelse cmp = Sql.Lt orelse cmp = Sql.Gt) + andalso UF.together (uf, ae1, ae2) + (* If we don't know one side of the comparision, not a contradiction. *) + | _ => false + in + not (List.exists contradiction atoms) <\oguard\> (fn _ => SOME (UF.classes uf)) + end + + fun addToEqs (eqs, n, e) = + case IM.find (eqs, n) of + (* Comparing to a constant is probably better than comparing to a + variable? Checking that existing constants match a new ones is + handled by [accumulateEqs]. *) + SOME (Prim _) => eqs + | _ => IM.insert (eqs, n, e) + + val accumulateEqs = + (* [NONE] means we have a contradiction. *) + fn (_, NONE) => NONE + | ((Prim p1, Prim p2), eqso) => + (case Prim.compare (p1, p2) of + EQUAL => eqso + | _ => NONE) + | ((QueryArg n, Prim p), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((QueryArg n, DmlRel r), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + | ((Prim p, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, Prim p)) + | ((DmlRel r, QueryArg n), SOME eqs) => SOME (addToEqs (eqs, n, DmlRel r)) + (* TODO: deal with equalities between [DmlRel]s and [Prim]s. + This would involve guarding the invalidation with a check for the + relevant comparisons. *) + | (_, eqso) => eqso + + val eqsOfClass : atomExp list -> atomExp IM.map option = + List.foldl accumulateEqs (SOME IM.empty) + o chooseTwos + + fun toAtomExps rel (cmp, e1, e2) = + let + val qa = + (* Here [NONE] means unkown. *) + fn Sql.SqConst p => SOME (Prim p) + | Sql.Field tf => SOME (Field tf) + | Sql.Inj (EPrim p, _) => SOME (Prim p) + | Sql.Inj (ERel n, _) => SOME (rel n) + (* We can't deal with anything else, e.g., CURRENT_TIMESTAMP + becomes Sql.Unmodeled, which becomes NONE here. *) + | _ => NONE + in + (cmp, qa e1, qa e2) + end + + val negateCmp = + fn Sql.Eq => Sql.Ne + | Sql.Ne => Sql.Eq + | Sql.Lt => Sql.Ge + | Sql.Le => Sql.Gt + | Sql.Gt => Sql.Le + | Sql.Ge => Sql.Lt + + fun normalizeAtom (negating, (cmp, e1, e2)) = + (* Restricting to Le/Lt and sorting the expressions in Eq/Ne helps with + simplification, where we put the triples in sets. *) + case (if negating then negateCmp cmp else cmp) of + Sql.Eq => (case AtomOptionKey.compare (e1, e2) of + LESS => (Sql.Eq, e2, e1) + | _ => (Sql.Eq, e1, e2)) + | Sql.Ne => (case AtomOptionKey.compare (e1, e2) of + LESS => (Sql.Ne, e2, e1) + | _ => (Sql.Ne, e1, e2)) + | Sql.Lt => (Sql.Lt, e1, e2) + | Sql.Le => (Sql.Le, e1, e2) + | Sql.Gt => (Sql.Lt, e2, e1) + | Sql.Ge => (Sql.Le, e2, e1) + + val markQuery : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps QueryArg) + + val markDml : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula -> + (Sql.cmp * atomExp option * atomExp option) formula = + mapFormula (toAtomExps DmlRel) + + (* No eqs should have key conflicts because no variable is in two + equivalence classes. *) + val mergeEqs : (atomExp IntBinaryMap.map option list + -> atomExp IntBinaryMap.map option) = + List.foldr (omap2 (IM.unionWith (fn _ => raise Fail "Sqlcache: ConflictMaps.mergeEqs"))) + (SOME IM.empty) + + val simplify = + map TS.listItems + o removeRedundant (fn (x, y) => TS.isSubset (y, x)) + o map (fn xs => TS.addList (TS.empty, xs)) + + fun dnf (fQuery, fDml) = + normalize simplify normalizeAtom Disj (Combo (Conj, [markQuery fQuery, markDml fDml])) + + val conflictMaps = + List.mapPartial (mergeEqs o map eqsOfClass) + o List.mapPartial equivClasses + o dnf + +end + +val conflictMaps = ConflictMaps.conflictMaps + + +(*************************************) +(* Program Instrumentation Utilities *) +(*************************************) + +val {check, store, flush, lock, ...} = getCache () + +val dummyTyp = (TRecord [], dummyLoc) + +fun stringExp s = (EPrim (Prim.String (Prim.Normal, s)), dummyLoc) + +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) + +val sequence = + fn (exp :: exps) => + let + val loc = dummyLoc + in + List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps + end + | _ => raise Fail "Sqlcache: sequence" + +(* Always increments negative indices as a hack we use later. *) +fun incRels inc = + MonoUtil.Exp.mapB + {typ = fn t' => t', + exp = fn bound => + (fn ERel n => ERel (if n >= bound orelse n < 0 then n + inc else n) + | e' => e'), + bind = fn (bound, MonoUtil.Exp.RelE _) => bound + 1 | (bound, _) => bound} + 0 + +fun fileTopLevelMapfoldB doTopLevelExp (decls, sideInfo) state = + let + fun doVal env ((x, n, t, exp, s), state) = + let + val (exp, state) = doTopLevelExp env exp state + in + ((x, n, t, exp, s), state) + end + fun doDecl' env (decl', state) = + case decl' of + DVal v => + let + val (v, state) = doVal env (v, state) + in + (DVal v, state) + end + | DValRec vs => + let + val (vs, state) = ListUtil.foldlMap (doVal env) state vs + in + (DValRec vs, state) + end + | _ => (decl', state) + fun doDecl (decl as (decl', loc), (env, state)) = + let + val env = MonoEnv.declBinds env decl + val (decl', state) = doDecl' env (decl', state) + in + ((decl', loc), (env, state)) + end + val (decls, (_, state)) = (ListUtil.foldlMap doDecl (MonoEnv.empty, state) decls) + in + ((decls, sideInfo), state) + end + +fun fileAllMapfoldB doExp file start = + case MonoUtil.File.mapfoldB + {typ = Search.return2, + exp = fn env => fn e' => fn s => Search.Continue (doExp env e' s), + decl = fn _ => Search.return2, + bind = doBind} + MonoEnv.empty file start of + Search.Continue x => x + | Search.Return _ => raise Fail "Sqlcache: fileAllMapfoldB" + +fun fileMap doExp file = #1 (fileAllMapfoldB (fn _ => fn e => fn _ => (doExp e, ())) file ()) + +(* TODO: make this a bit prettier.... *) +(* TODO: factour out identical subexpressions to the same variable.... *) +val simplifySql = + let + fun factorOutNontrivial text = + let + val loc = dummyLoc + val strcat = + fn (e1, (EPrim (Prim.String (Prim.Normal, "")), _)) => e1 + | ((EPrim (Prim.String (Prim.Normal, "")), _), e2) => e2 + | (e1, e2) => (EStrcat (e1, e2), loc) + val chunks = Sql.chunkify text + val (newText, newVariables) = + (* Important that this is foldr (to oppose foldl below). *) + List.foldr + (fn (chunk, (qText, newVars)) => + (* Variable bound to the head of newVars will have the lowest index. *) + case chunk of + (* EPrim should always be a string in this case. *) + Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars) + | Sql.Exp e => + let + val n = length newVars + in + (* This is the (n+1)th new variable, so there are + already n new variables bound, so we increment + indices by n. *) + (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars) + end + | Sql.String s => (strcat (stringExp s, qText), newVars)) + (stringExp "", []) + chunks + fun wrapLets e' = + (* Important that this is foldl (to oppose foldr above). *) + List.foldl (fn (v, e') => ELet ("sqlArg", stringTyp, v, (e', loc))) + e' + newVariables + val numArgs = length newVariables + in + (newText, wrapLets, numArgs) + end + fun doExp exp' = + let + val text = case exp' of + EQuery {query = text, ...} => text + | EDml (text, _) => text + | _ => raise Fail "Sqlcache: simplifySql (a)" + val (newText, wrapLets, numArgs) = factorOutNontrivial text + val newExp' = case exp' of + EQuery q => EQuery {query = newText, + exps = #exps q, + tables = #tables q, + state = #state q, + body = #body q, + initial = #initial q} + | EDml (_, failureMode) => EDml (newText, failureMode) + | _ => raise Fail "Sqlcache: simplifySql (b)" + in + (* Increment once for each new variable just made. This is + where we use the negative De Bruijn indices hack. *) + (* TODO: please don't use that hack. As anyone could have + predicted, it was incomprehensible a year later.... *) + wrapLets (#1 (incRels numArgs (newExp', dummyLoc))) + end + in + fileMap (fn exp' => case exp' of + EQuery _ => doExp exp' + | EDml _ => doExp exp' + | _ => exp') + end + + +(**********************) +(* Mono Type Checking *) +(**********************) + +fun typOfExp' (env : MonoEnv.env) : exp' -> typ option = + fn EPrim p => SOME (TFfi ("Basis", case p of + Prim.Int _ => "int" + | Prim.Float _ => "double" + | Prim.String _ => "string" + | Prim.Char _ => "char"), + dummyLoc) + | ERel n => SOME (#2 (MonoEnv.lookupERel env n)) + | ENamed n => SOME (#2 (MonoEnv.lookupENamed env n)) + (* ASK: okay to make a new [ref] each time? *) + | ECon (dk, PConVar nCon, _) => + let + val (_, _, nData) = MonoEnv.lookupConstructor env nCon + val (_, cs) = MonoEnv.lookupDatatype env nData + in + SOME (TDatatype (nData, ref (dk, cs)), dummyLoc) + end + | ECon (_, PConFfi {mod = s, datatyp, ...}, _) => SOME (TFfi (s, datatyp), dummyLoc) + | ENone t => SOME (TOption t, dummyLoc) + | ESome (t, _) => SOME (TOption t, dummyLoc) + | EFfi _ => NONE + | EFfiApp _ => NONE + | EApp (e1, e2) => (case typOfExp env e1 of + SOME (TFun (_, t), _) => SOME t + | _ => NONE) + | EAbs (_, t1, t2, _) => SOME (TFun (t1, t2), dummyLoc) + (* ASK: is this right? *) + | EUnop (unop, e) => (case unop of + "!" => SOME (TFfi ("Basis", "bool"), dummyLoc) + | "-" => typOfExp env e + | _ => NONE) + (* ASK: how should this (and other "=> NONE" cases) work? *) + | EBinop _ => NONE + | ERecord fields => SOME (TRecord (map (fn (s, _, t) => (s, t)) fields), dummyLoc) + | EField (e, s) => (case typOfExp env e of + SOME (TRecord fields, _) => + omap #2 (List.find (fn (s', _) => s = s') fields) + | _ => NONE) + | ECase (_, _, {result, ...}) => SOME result + | EStrcat _ => SOME (TFfi ("Basis", "string"), dummyLoc) + | EWrite _ => SOME (TRecord [], dummyLoc) + | ESeq (_, e) => typOfExp env e + | ELet (s, t, e1, e2) => typOfExp (MonoEnv.pushERel env s t (SOME e1)) e2 + | EClosure _ => NONE + | EUnurlify (_, t, _) => SOME t + | EQuery {state, ...} => SOME state + | e => NONE + +and typOfExp env (e', loc) = typOfExp' env e' + + +(***********) +(* Caching *) +(***********) + +type state = InvalInfo.state + +datatype subexp = Cachable of InvalInfo.t * (state -> exp * state) | Impure of exp + +val isImpure = + fn Cachable _ => false + | Impure _ => true + +val runSubexp : subexp * state -> exp * state = + fn (Cachable (_, f), state) => f state + | (Impure e, state) => (e, state) + +val invalInfoOfSubexp = + fn Cachable (invalInfo, _) => invalInfo + | Impure _ => raise Fail "Sqlcache: invalInfoOfSubexp" + +fun cacheWrap (env, exp, typ, args, index) = + let + val loc = dummyLoc + val rel0 = (ERel 0, loc) + in + case MonoFooify.urlify env (rel0, typ) of + NONE => NONE + | SOME urlified => + let + (* We ensure before this step that all arguments aren't effectful. + by turning them into local variables as needed. *) + val argsInc = map (incRels 1) args + val check = (check (index, args), loc) + val store = (store (index, argsInc, urlified), loc) + in + SOME (ECase (check, + [((PNone stringTyp, loc), + (ELet ("q", typ, exp, (ESeq (store, rel0), loc)), loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* Boolean is false because we're not unurlifying from a cookie. *) + (EUnurlify (rel0, typ, false), loc))], + {disc = (TOption stringTyp, loc), result = typ})) + end + end + +val expSize = MonoUtil.Exp.fold {typ = #2, exp = fn (_, n) => n+1} 0 + +(* TODO: pick a number. *) +val sizeWorthCaching = 5 + +val worthCaching = + fn EQuery _ => true + | exp' => expSize (exp', dummyLoc) > sizeWorthCaching + +fun cacheExp (env, exp', invalInfo, state : state) = + case worthCaching exp' <\oguard\> (fn _ => typOfExp' env exp') of + NONE => NONE + | SOME (TFun _, _) => NONE + | SOME typ => + InvalInfo.orderArgs (invalInfo, (exp', dummyLoc)) + <\obind\> + (fn args => + List.foldr (fn (arg, acc) => + acc + <\obind\> + (fn args' => + (case arg of + AsIs exp => SOME exp + | Urlify exp => + (typOfExp env exp) + <\obind\> + (fn typ => MonoFooify.urlify env (exp, typ))) + <\obind\> + (fn arg' => SOME (arg' :: args')))) + (SOME []) + args + <\obind\> + (fn args' => + cacheWrap (env, (exp', dummyLoc), typ, args', #index state) + <\obind\> + (fn cachedExp => + SOME (cachedExp, + InvalInfo.updateState (invalInfo, length args', state))))) + +fun cacheQuery (effs, env, q) : subexp = + let + (* We use dummyTyp here. I think this is okay because databases don't + store (effectful) functions, but perhaps there's some pathalogical + corner case missing.... *) + fun safe bound = + not + o effectful effs + (iterate (fn env => MonoEnv.pushERel env "_" dummyTyp NONE) + bound + env) + val {query = queryText, initial, body, ...} = q + val attempt = + (* Ziv misses Haskell's do notation.... *) + (safe 0 queryText andalso safe 0 initial andalso safe 2 body) + <\oguard\> + (fn _ => + Sql.parse Sql.query queryText + <\obind\> + (fn queryParsed => + let + val invalInfo = InvalInfo.singleton queryParsed + fun mkExp state = + case cacheExp (env, EQuery q, invalInfo, state) of + NONE => ((EQuery q, dummyLoc), state) + | SOME (cachedExp, state) => ((cachedExp, dummyLoc), state) + in + SOME (Cachable (invalInfo, mkExp)) + end)) + in + case attempt of + NONE => Impure (EQuery q, dummyLoc) + | SOME subexp => subexp + end + +fun cacheTree (effs : IS.set) ((env, exp as (exp', loc)), state) = + let + fun wrapBindN (f : exp list -> exp') + (args : ((MonoEnv.env * exp) * unbind) list) = + let + val (subexps, state) = + ListUtil.foldlMap (cacheTree effs) + state + (map #1 args) + fun mkExp state = mapFst (fn exps => (f exps, loc)) + (ListUtil.foldlMap runSubexp state subexps) + val attempt = + if List.exists isImpure subexps + then NONE + else (List.foldl (omap2 InvalInfo.union) + (SOME InvalInfo.empty) + (ListPair.map + (fn (subexp, (_, unbinds)) => + InvalInfo.unbind (invalInfoOfSubexp subexp, unbinds)) + (subexps, args))) + <\obind\> + (fn invalInfo => + SOME (Cachable (invalInfo, + fn state => + case cacheExp (env, + f (map (#2 o #1) args), + invalInfo, + state) of + NONE => mkExp state + | SOME (e', state) => ((e', loc), state)), + state)) + in + case attempt of + SOME (subexp, state) => (subexp, state) + | NONE => mapFst Impure (mkExp state) + end + fun wrapBind1 f arg = + wrapBindN (fn [arg] => f arg + | _ => raise Fail "Sqlcache: cacheTree (a)") [arg] + fun wrapBind2 f (arg1, arg2) = + wrapBindN (fn [arg1, arg2] => f (arg1, arg2) + | _ => raise Fail "Sqlcache: cacheTree (b)") [arg1, arg2] + fun wrapN f es = wrapBindN f (map (fn e => ((env, e), Unknowns 0)) es) + fun wrap1 f e = wrapBind1 f ((env, e), Unknowns 0) + fun wrap2 f (e1, e2) = wrapBind2 f (((env, e1), Unknowns 0), ((env, e2), Unknowns 0)) + in + case exp' of + ECon (dk, pc, SOME e) => wrap1 (fn e => ECon (dk, pc, SOME e)) e + | ESome (t, e) => wrap1 (fn e => ESome (t, e)) e + | EFfiApp (s1, s2, args) => + if ffiEffectful (s1, s2) + then (Impure exp, state) + else wrapN (fn es => + EFfiApp (s1, s2, ListPair.map (fn (e, (_, t)) => (e, t)) (es, args))) + (map #1 args) + | EApp (e1, e2) => wrap2 EApp (e1, e2) + | EAbs (s, t1, t2, e) => + wrapBind1 (fn e => EAbs (s, t1, t2, e)) + ((MonoEnv.pushERel env s t1 NONE, e), Unknowns 1) + | EUnop (s, e) => wrap1 (fn e => EUnop (s, e)) e + | EBinop (bi, s, e1, e2) => wrap2 (fn (e1, e2) => EBinop (bi, s, e1, e2)) (e1, e2) + | ERecord fields => + wrapN (fn es => ERecord (ListPair.map (fn (e, (s, _, t)) => (s, e, t)) (es, fields))) + (map #2 fields) + | EField (e, s) => wrap1 (fn e => EField (e, s)) e + | ECase (e, cases, {disc, result}) => + wrapBindN (fn (e::es) => + ECase (e, + (ListPair.map (fn (e, (p, _)) => (p, e)) (es, cases)), + {disc = disc, result = result}) + | _ => raise Fail "Sqlcache: cacheTree (c)") + (((env, e), Unknowns 0) + :: map (fn (p, e) => + ((MonoEnv.patBinds env p, e), Unknowns (MonoEnv.patBindsN p))) + cases) + | EStrcat (e1, e2) => wrap2 EStrcat (e1, e2) + (* We record page writes, so they're cachable. *) + | EWrite e => wrap1 EWrite e + | ESeq (e1, e2) => wrap2 ESeq (e1, e2) + | ELet (s, t, e1, e2) => + wrapBind2 (fn (e1, e2) => ELet (s, t, e1, e2)) + (((env, e1), Unknowns 0), + ((MonoEnv.pushERel env s t (SOME e1), e2), Known e1)) + (* ASK: | EClosure (n, es) => ? *) + | EUnurlify (e, t, b) => wrap1 (fn e => EUnurlify (e, t, b)) e + | EQuery q => (cacheQuery (effs, env, q), state) + | _ => (if effectful effs env exp + then Impure exp + else Cachable (InvalInfo.empty, + fn state => + case cacheExp (env, exp', InvalInfo.empty, state) of + NONE => ((exp', loc), state) + | SOME (exp', state) => ((exp', loc), state)), + state) + end + +fun addCaching file = + let + val effs = effectfulDecls file + fun doTopLevelExp env exp state = runSubexp (cacheTree effs ((env, exp), state)) + in + (fileTopLevelMapfoldB doTopLevelExp + file + {tableToIndices = SIMM.empty, + indexToInvalInfo = IM.empty, + ffiInfo = [], + index = 0}, + effs) + end + + +(************) +(* Flushing *) +(************) + +structure Invalidations = struct + + val loc = dummyLoc + + val optionAtomExpToExp = + fn NONE => (ENone stringTyp, loc) + | SOME e => (ESome (stringTyp, + (case e of + DmlRel n => ERel n + | Prim p => EPrim p + (* TODO: make new type containing only these two. *) + | _ => raise Fail "Sqlcache: Invalidations.optionAtomExpToExp", + loc)), + loc) + + fun eqsToInvalidation numArgs eqs = + List.tabulate (numArgs, (fn n => IM.find (eqs, n))) + + (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here + represents unknown, which means a wider invalidation. *) + val rec madeRedundantBy : atomExp option list * atomExp option list -> bool = + fn ([], []) => true + | (_ :: xs, NONE :: ys) => madeRedundantBy (xs, ys) + | (SOME x :: xs, SOME y :: ys) => (case AtomExpKey.compare (x, y) of + EQUAL => madeRedundantBy (xs, ys) + | _ => false) + | _ => false + + fun invalidations ((invalInfo, numArgs), dml) = + let + val query = InvalInfo.query invalInfo + in + (map (map optionAtomExpToExp) + o removeRedundant madeRedundantBy + o map (eqsToInvalidation numArgs) + o conflictMaps) + (pairToFormulas (query, dml)) + end + +end + +val invalidations = Invalidations.invalidations + +fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state), effs) = + let + val flushes = List.concat + o map (fn (i, argss) => map (fn args => flush (i, args)) argss) + val doExp = + fn dmlExp as EDml (dmlText, failureMode) => + let + val inval = + case Sql.parse Sql.dml dmlText of + SOME dmlParsed => + SOME (map (fn i => case IM.find (indexToInvalInfo, i) of + SOME invalInfo => + (i, invalidations (invalInfo, dmlParsed)) + (* TODO: fail more gracefully. *) + (* This probably means invalidating everything.... *) + | NONE => raise Fail "Sqlcache: addFlushing (a)") + (SIMM.findList (tableToIndices, tableOfDml dmlParsed))) + | NONE => NONE + in + case inval of + (* TODO: fail more gracefully. *) + NONE => (Print.preface ("DML", MonoPrint.p_exp MonoEnv.empty dmlText); + raise Fail "Sqlcache: addFlushing (b)") + | SOME invs => sequence (flushes invs @ [dmlExp]) + end + | e' => e' + val file = fileMap doExp file + + in + ffiInfoRef := ffiInfo; + file + end + + +(***********) +(* Locking *) +(***********) + +(* TODO: do this less evilly by not relying on specific FFI names, please? *) +fun locksNeeded (lockMap : {store : IIMM.multimap, flush : IIMM.multimap}) = + MonoUtil.Exp.fold + {typ = #2, + exp = fn (EFfiApp ("Sqlcache", x, _), state as {store, flush}) => + (case Int.fromString (String.extract (x, 5, NONE)) of + NONE => state + | SOME index => + if String.isPrefix "flush" x + then {store = store, flush = IS.add (flush, index)} + else if String.isPrefix "store" x + then {store = IS.add (store, index), flush = flush} + else state) + | (ENamed n, {store, flush}) => + {store = IS.union (store, IIMM.findSet (#store lockMap, n)), + flush = IS.union (flush, IIMM.findSet (#flush lockMap, n))} + | (_, state) => state} + {store = IS.empty, flush = IS.empty} + +fun lockMapOfFile file = + transitiveAnalysis + (fn ((_, name, _, e, _), state) => + let + val locks = locksNeeded state e + in + {store = IIMM.insertSet (#store state, name, #store locks), + flush = IIMM.insertSet (#flush state, name, #flush locks)} + end) + {store = IIMM.empty, flush = IIMM.empty} + file + +fun exports (decls, _) = + List.foldl (fn ((DExport (_, _, n, _, _, _), _), ns) => IS.add (ns, n) + | (_, ns) => ns) + IS.empty + decls + +fun wrapLocks (locks, (exp', loc)) = + case exp' of + EAbs (s, t1, t2, exp) => (EAbs (s, t1, t2, wrapLocks (locks, exp)), loc) + | _ => (List.foldr (fn (l, e') => sequence [lock l, e']) exp' locks, loc) + +fun addLocking file = + let + val lockMap = lockMapOfFile file + fun lockList {store, flush} = + let + val ls = map (fn i => (i, true)) (IS.listItems flush) + @ map (fn i => (i, false)) (IS.listItems (IS.difference (store, flush))) + in + ListMergeSort.sort (fn ((i, _), (j, _)) => i > j) ls + end + fun locksOfName n = + lockList {flush = IIMM.findSet (#flush lockMap, n), + store = IIMM.findSet (#store lockMap, n)} + val locksOfExp = lockList o locksNeeded lockMap + val expts = exports file + fun doVal (v as (x, n, t, exp, s)) = + if IS.member (expts, n) + then (x, n, t, wrapLocks ((locksOfName n), exp), s) + else v + val doDecl = + fn (DVal v, loc) => (DVal (doVal v), loc) + | (DValRec vs, loc) => (DValRec (map doVal vs), loc) + | (DTask (exp1, exp2), loc) => (DTask (exp1, wrapLocks (locksOfExp exp2, exp2)), loc) + | decl => decl + in + mapFst (map doDecl) file + end + + +(************************) +(* Compiler Entry Point *) +(************************) + +val inlineSql = + let + val doExp = + (* TODO: EQuery, too? *) + (* ASK: should this live in [MonoOpt]? *) + fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) => + let + val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases + in + ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)}) + end + | e => e + in + fileMap doExp + end + +fun insertAfterDatatypes ((decls, sideInfo), newDecls) = + let + val (datatypes, others) = List.partition (fn (DDatatype _, _) => true | _ => false) decls + in + (datatypes @ newDecls @ others, sideInfo) + end + +val go' = addLocking o addFlushing o addCaching o simplifySql o inlineSql + +fun go file = + let + (* TODO: do something nicer than [Sql] being in one of two modes. *) + val () = (resetFfiInfo (); Sql.sqlcacheMode := true) + val file = go' file + (* Important that this happens after [MonoFooify.urlify] calls! *) + val fmDecls = MonoFooify.getNewFmDecls () + val () = Sql.sqlcacheMode := false + val file = insertAfterDatatypes (file, rev fmDecls) + in + MonoReduce.reduce file + end + +end diff --git a/src/sqlite.sig b/src/sqlite.sig new file mode 100644 index 0000000..97475a0 --- /dev/null +++ b/src/sqlite.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2008-2009, 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 SQLITE = sig + +end diff --git a/src/sqlite.sml b/src/sqlite.sml new file mode 100644 index 0000000..a9b6389 --- /dev/null +++ b/src/sqlite.sml @@ -0,0 +1,855 @@ + (* Copyright (c) 2009-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 SQLite :> SQLITE = struct + +open Settings +open Print.PD +open Print + +fun p_sql_type t = + case t of + Int => "integer" + | Float => "real" + | String => "text" + | Char => "text" + | Bool => "integer" + | Time => "text" + | Blob => "blob" + | Channel => "integer" + | Client => "integer" + | Nullable t => p_sql_type t + +val ident = String.translate (fn #"'" => "PRIME" + | ch => str ch) + +fun checkRel (table, checkNullable) (s, xts) = + let + val q = "SELECT COUNT(*) FROM sqlite_master WHERE type = '" ^ table ^ "' AND name = '" + ^ s ^ "'" + in + box [string "if (sqlite3_prepare_v2(conn->conn, \"", + string q, + string "\", -1, &stmt, NULL) != SQLITE_OK) {", + newline, + box [string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Query preparation failed:<br />", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "while ((res = sqlite3_step(stmt)) == SQLITE_BUSY)", + newline, + box [string "sleep(1);", + newline], + newline, + string "if (res == SQLITE_DONE) {", + newline, + box [string "sqlite3_finalize(stmt);", + newline, + string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"No row returned:<br />", + string q, + string "\");", + newline], + string "}", + newline, + newline, + string "if (res != SQLITE_ROW) {", + newline, + box [string "sqlite3_finalize(stmt);", + newline, + string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Error getting row:<br />", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if (sqlite3_column_count(stmt) != 1) {", + newline, + box [string "sqlite3_finalize(stmt);", + newline, + string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Bad column count:<br />", + string q, + string "\");", + newline], + string "}", + newline, + newline, + + string "if (sqlite3_column_int(stmt, 0) != 1) {", + newline, + box [string "sqlite3_finalize(stmt);", + newline, + string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"Table '", + string s, + string "' does not exist.\");", + newline], + string "}", + newline, + newline, + string "sqlite3_finalize(stmt);", + newline] + end + +fun init {dbstring, prepared = ss, tables, views, sequences} = + let + val db = ref dbstring + in + app (fn s => + case String.fields (fn ch => ch = #"=") s of + [name, value] => + (case name of + "dbname" => db := value + | _ => ()) + | _ => ()) (String.tokens Char.isSpace dbstring); + + box [string "typedef struct {", + newline, + box [string "sqlite3 *conn;", + newline, + p_list_sepi (box []) + (fn i => fn _ => + box [string "sqlite3_stmt *p", + string (Int.toString i), + string ";", + newline]) + ss], + string "} uw_conn;", + newline, + newline, + + string "static void uw_client_init(void) {", + newline, + box [string "uw_sqlfmtInt = \"%lld%n\";", + newline, + string "uw_sqlfmtFloat = \"%.16g%n\";", + newline, + string "uw_Estrings = 0;", + newline, + string "uw_sql_type_annotations = 0;", + newline, + string "uw_sqlsuffixString = \"\";", + newline, + string "uw_sqlsuffixChar = \"\";", + newline, + string "uw_sqlsuffixBlob = \"\";", + newline, + string "uw_sqlfmtUint4 = \"%u%n\";", + newline], + string "}", + newline, + newline, + + if #persistent (currentProtocol ()) then + box [string "static void uw_db_validate(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "sqlite3_stmt *stmt;", + newline, + string "int res;", + newline, + newline, + p_list_sep newline (checkRel ("table", true)) tables, + p_list_sep newline (fn name => checkRel ("table", true) + (name, [("id", Settings.Client)])) sequences, + p_list_sep newline (checkRel ("view", false)) views, + string "}", + newline, + newline, + + string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + newline, + + p_list_sepi newline (fn i => fn (s, _) => + let + fun uhoh this s args = + box [p_list_sepi (box []) + (fn j => fn () => + box [string + "sqlite3_finalize(conn->p", + string (Int.toString j), + string ");", + newline]) + (List.tabulate (i, fn _ => ())), + box (if this then + [string + "sqlite3_finalize(conn->p", + string (Int.toString i), + string ");", + newline] + else + []), + string "sqlite3_close(conn->conn);", + newline, + string "uw_error(ctx, FATAL, \"", + string s, + string "\"", + p_list_sep (box []) (fn s => box [string ", ", + string s]) args, + string ");", + newline] + in + box [string "if (sqlite3_prepare_v2(conn->conn, \"", + string (Prim.toCString s), + string "\", -1, &conn->p", + string (Int.toString i), + string ", NULL) != SQLITE_OK) {", + newline, + box [string "char msg[1024];", + newline, + string "strncpy(msg, sqlite3_errmsg(conn->conn), 1024);", + newline, + string "msg[1023] = 0;", + newline, + uhoh false ("Error preparing statement: " + ^ Prim.toCString s ^ "<br />%s") ["msg"]], + string "}", + newline] + end) + ss, + + string "}"] + else + box [string "static void uw_db_prepare(uw_context ctx) { }", + newline, + string "static void uw_db_validate(uw_context ctx) { }"], + newline, + newline, + + string "static void uw_db_init(uw_context ctx) {", + newline, + string "sqlite3 *sqlite;", + newline, + string "sqlite3_stmt *stmt;", + newline, + string "uw_conn *conn;", + newline, + newline, + string "if (sqlite3_open(\"", + string (!db), + string "\", &sqlite) != SQLITE_OK) uw_error(ctx, FATAL, ", + string "\"Can't open SQLite database.\");", + newline, + newline, + string "if (uw_database_max < SIZE_MAX) {", + newline, + box [string "char buf[100];", + newline, + newline, + + string "sprintf(buf, \"PRAGMA max_page_count = %llu\", (unsigned long long)(uw_database_max / 1024));", + newline, + newline, + + string "if (sqlite3_prepare_v2(sqlite, buf, -1, &stmt, NULL) != SQLITE_OK) {", + newline, + box [string "sqlite3_close(sqlite);", + newline, + string "uw_error(ctx, FATAL, \"Can't prepare max_page_count query for SQLite database\");", + newline], + string "}", + newline, + newline, + + string "if (sqlite3_step(stmt) != SQLITE_ROW) {", + newline, + box [string "sqlite3_finalize(stmt);", + newline, + string "sqlite3_close(sqlite);", + newline, + string "uw_error(ctx, FATAL, \"Can't set max_page_count parameter for SQLite database\");", + newline], + string "}", + newline, + newline, + + string "sqlite3_finalize(stmt);", + newline], + string "}", + newline, + newline, + + string "conn = calloc(1, sizeof(uw_conn));", + newline, + string "conn->conn = sqlite;", + newline, + string "uw_set_db(ctx, conn);", + newline, + string "uw_db_validate(ctx);", + newline, + string "uw_db_prepare(ctx);", + newline, + string "}", + newline, + newline, + + string "static void uw_db_close(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + p_list_sepi (box []) + (fn i => fn _ => + box [string "if (conn->p", + string (Int.toString i), + string ") sqlite3_finalize(conn->p", + string (Int.toString i), + string ");", + newline]) + ss, + string "sqlite3_close(conn->conn);", + newline, + string "}", + newline, + newline, + + string "static int uw_db_begin(uw_context ctx, int could_write) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + newline, + string "if (sqlite3_exec(conn->conn, \"BEGIN\", NULL, NULL, NULL) == SQLITE_OK)", + newline, + box [string "return 0;", + newline], + string "else {", + newline, + box [string "fprintf(stderr, \"Begin error: %s<br />\", sqlite3_errmsg(conn->conn));", + newline, + string "return 1;", + newline], + string "}", + newline, + string "}", + newline, + string "static int uw_db_commit(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "if (sqlite3_exec(conn->conn, \"COMMIT\", NULL, NULL, NULL) == SQLITE_OK)", + newline, + box [string "return 0;", + newline], + string "else {", + newline, + box [string "fprintf(stderr, \"Commit error: %s<br />\", sqlite3_errmsg(conn->conn));", + newline, + string "return 1;", + newline], + string "}", + newline, + string "}", + newline, + newline, + + string "static int uw_db_rollback(uw_context ctx) {", + newline, + string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "if (sqlite3_exec(conn->conn, \"ROLLBACK\", NULL, NULL, NULL) == SQLITE_OK)", + newline, + box [string "return 0;", + newline], + string "else {", + newline, + box [string "fprintf(stderr, \"Rollback error: %s<br />\", sqlite3_errmsg(conn->conn));", + newline, + string "return 1;", + newline], + string "}", + newline, + string "}", + newline, + newline] + end + +val fmt = "\"%Y-%m-%d %H:%M:%S\"" + +fun p_getcol {loc, wontLeakStrings, col = i, typ = t} = + let + fun p_unsql t = + case t of + Int => box [string "sqlite3_column_int64(stmt, ", string (Int.toString i), string ")"] + | Float => box [string "sqlite3_column_double(stmt, ", string (Int.toString i), string ")"] + | String => + if wontLeakStrings then + box [string "(uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string ")"] + else + box [string "uw_strdup(ctx, (uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string "))"] + | Char => box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")[0]"] + | Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"] + | Time => box [string "uw_Basis_stringToTimef_error(ctx, ", + string fmt, + string ", (uw_Basis_string)sqlite3_column_text(stmt, ", + string (Int.toString i), + string "))"] + | Blob => box [string "({", + newline, + string "char *data = (char *)sqlite3_column_blob(stmt, ", + string (Int.toString i), + string ");", + newline, + string "int len = sqlite3_column_bytes(stmt, ", + string (Int.toString i), + string ");", + newline, + string "uw_Basis_blob b = {len, uw_memdup(ctx, data, len)};", + newline, + string "b;", + newline, + string "})"] + | Channel => box [string "({", + newline, + string "sqlite3_int64 n = sqlite3_column_int64(stmt, ", + string (Int.toString i), + string ");", + newline, + string "uw_Basis_channel ch = {n >> 32, n & 0xFFFFFFFF};", + newline, + string "ch;", + newline, + string "})"] + | Client => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"] + + | Nullable _ => raise Fail "Postgres: Recursive Nullable" + + fun getter t = + case t of + Nullable t => + box [string "(sqlite3_column_type(stmt, ", + string (Int.toString i), + string ") == SQLITE_NULL ? NULL : ", + case t of + String => getter t + | _ => box [string "({", + newline, + string (p_sql_ctype t), + space, + string "*tmp = uw_malloc(ctx, sizeof(", + string (p_sql_ctype t), + string "));", + newline, + string "*tmp = ", + getter t, + string ";", + newline, + string "tmp;", + newline, + string "})"], + string ")"] + | _ => + box [string "(sqlite3_column_type(stmt, ", + string (Int.toString i), + string ") == SQLITE_NULL ? ", + box [string "({", + string (p_sql_ctype t), + space, + string "tmp;", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Unexpectedly NULL field #", + string (Int.toString i), + string "\");", + newline, + string "tmp;", + newline, + string "})"], + string " : ", + p_unsql t, + string ")"] + in + getter t + end + +fun queryCommon {loc, query, cols, doCols} = + box [string "int r;", + newline, + + string "sqlite3_reset(stmt);", + newline, + + string "uw_end_region(ctx);", + newline, + string "while ((r = sqlite3_step(stmt)) == SQLITE_ROW) {", + newline, + doCols p_getcol, + string "}", + newline, + newline, + + string "if (r == SQLITE_BUSY) {", + box [string "sleep(1);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");", + newline], + string "}", + newline, + newline, + + string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": query step failed: %s<br />%s\", ", + query, + string ", sqlite3_errmsg(conn->conn));", + newline, + newline] + +fun query {loc, cols, doCols} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "sqlite3_stmt *stmt;", + newline, + newline, + string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", sqlite3_errmsg(conn->conn), query);", + newline, + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);", + newline, + newline, + + queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}, + + string "uw_pop_cleanup(ctx);", + newline] + +val p_pre_inputs = + p_list_sepi (box []) + (fn i => fn t => + case t of + Char => box [string "char arg", + string (Int.toString (i + 1)), + string "s = {arg", + string (Int.toString (i + 1)), + string ", 0};", + newline] + | _ => box []) + +fun p_inputs loc = + p_list_sepi (box []) + (fn i => fn t => + let + fun bind (t, arg) = + case t of + Int => box [string "sqlite3_bind_int64(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ")"] + | Float => box [string "sqlite3_bind_double(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ")"] + | String => box [string "sqlite3_bind_text(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ", -1, SQLITE_TRANSIENT)"] + | Char => box [string "sqlite3_bind_text(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string "s, -1, SQLITE_TRANSIENT)"] + | Bool => box [string "sqlite3_bind_int(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ")"] + | Time => box [string "sqlite3_bind_text(stmt, ", + string (Int.toString (i + 1)), + string ", uw_Basis_timef(ctx, ", + string fmt, + string ", ", + arg, + string "), -1, SQLITE_TRANSIENT)"] + | Blob => box [string "sqlite3_bind_blob(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ".data, ", + arg, + string ".size, SQLITE_TRANSIENT)"] + | Channel => box [string "sqlite3_bind_int64(stmt, ", + string (Int.toString (i + 1)), + string ", ((sqlite3_int64)", + arg, + string ".cli << 32) | ", + arg, + string ".chn)"] + | Client => box [string "sqlite3_bind_int(stmt, ", + string (Int.toString (i + 1)), + string ", ", + arg, + string ")"] + | Nullable t => box [string "(", + arg, + string " == NULL ? sqlite3_bind_null(stmt, ", + string (Int.toString (i + 1)), + string ") : ", + bind (t, case t of + String => arg + | _ => box [string "(*", arg, string ")"]), + string ")"] + in + box [string "if (", + bind (t, box [string "arg", string (Int.toString (i + 1))]), + string " != SQLITE_OK) uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error binding parameter #", + string (Int.toString (i + 1)), + string ": %s\", sqlite3_errmsg(conn->conn));", + newline] + end) + +fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + p_pre_inputs inputs, + if nested then + box [string "sqlite3_stmt *stmt;", + newline] + else + box [string "sqlite3_stmt *stmt = conn->p", + string (Int.toString id), + string ";", + newline, + newline, + + string "if (stmt == NULL) {", + newline], + + string "if (sqlite3_prepare_v2(conn->conn, \"", + string (Prim.toCString query), + string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ", + string (Prim.toCString query), + string "<br />%s\", sqlite3_errmsg(conn->conn));", + newline, + if nested then + box [string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);", + newline] + else + box [string "conn->p", + string (Int.toString id), + string " = stmt;", + newline, + string "}", + newline, + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);", + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);", + newline], + newline, + + p_inputs loc inputs, + newline, + + queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", + string (Prim.toCString query), + string "\""]}, + + string "uw_pop_cleanup(ctx);", + newline, + if nested then + box [] + else + box [string "uw_pop_cleanup(ctx);", + newline]] + +fun dmlCommon {loc, dml, mode} = + box [string "int r;", + newline, + + string "if ((r = sqlite3_step(stmt)) == SQLITE_BUSY) {", + box [string "sleep(1);", + newline, + string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");", + newline], + string "}", + newline, + newline, + + string "if (r != SQLITE_DONE) ", + case mode of + Settings.Error => box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": DML step failed: %s<br />%s\", ", + dml, + string ", sqlite3_errmsg(conn->conn));"] + | Settings.None => string "uw_set_error_message(ctx, sqlite3_errmsg(conn->conn));", + newline] + +fun dml (loc, mode) = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "sqlite3_stmt *stmt;", + newline, + newline, + string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", dml, sqlite3_errmsg(conn->conn));", + newline, + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);", + newline, + newline, + + dmlCommon {loc = loc, dml = string "dml", mode = mode}, + + string "uw_pop_cleanup(ctx);", + newline] + +fun dmlPrepared {loc, id, dml, inputs, mode = mode} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + p_pre_inputs inputs, + string "sqlite3_stmt *stmt = conn->p", + string (Int.toString id), + string ";", + newline, + newline, + + string "if (stmt == NULL) {", + newline, + box [string "if (sqlite3_prepare_v2(conn->conn, \"", + string (Prim.toCString dml), + string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ", + string (Prim.toCString dml), + string "<br />%s\", sqlite3_errmsg(conn->conn));", + newline, + string "conn->p", + string (Int.toString id), + string " = stmt;", + newline], + string "}", + newline, + + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);", + newline, + string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);", + newline, + + p_inputs loc inputs, + newline, + + dmlCommon {loc = loc, dml = box [string "\"", + string (Prim.toCString dml), + string "\""], mode = mode}, + + string "uw_pop_cleanup(ctx);", + newline, + string "uw_pop_cleanup(ctx);", + newline] + +fun nextval {loc, seqE, seqName} = + box [string "uw_conn *conn = uw_get_db(ctx);", + newline, + string "char *insert = ", + case seqName of + SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES (NULL)\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ", + seqE, + string ", \" VALUES ()\"))"], + string ";", + newline, + string "char *delete = ", + case seqName of + SOME s => string ("\"DELETE FROM " ^ s ^ "\"") + | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ", + seqE, + string ")"], + string ";", + newline, + newline, + + string "if (sqlite3_exec(conn->conn, insert, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' INSERT failed: %s\", sqlite3_errmsg(conn->conn));", + newline, + string "n = sqlite3_last_insert_rowid(conn->conn);", + newline, + string "if (sqlite3_exec(conn->conn, delete, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' DELETE failed: %s\", sqlite3_errmsg(conn->conn));", + newline] + +fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called" +fun setval _ = raise Fail "SQLite.setval called" + +fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''" + | #"\000" => "" + | ch => str ch) + s ^ "'" + +fun p_cast (s, _) = s + +fun p_blank _ = "?" + +val () = addDbms {name = "sqlite", + randomFunction = "RANDOM", + header = Config.sqheader, + link = "-lsqlite3", + init = init, + p_sql_type = p_sql_type, + query = query, + queryPrepared = queryPrepared, + dml = dml, + dmlPrepared = dmlPrepared, + nextval = nextval, + nextvalPrepared = nextvalPrepared, + setval = setval, + sqlifyString = sqlifyString, + p_cast = p_cast, + p_blank = p_blank, + supportsDeleteAs = false, + supportsUpdateAs = false, + createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTOINCREMENT)", + textKeysNeedLengths = false, + supportsNextval = false, + supportsNestedPrepared = false, + sqlPrefix = "", + supportsOctetLength = false, + trueString = "1", + falseString = "0", + onlyUnion = false, + nestedRelops = false, + windowFunctions = false, + supportsIsDistinctFrom = false} + +end diff --git a/src/static.sig b/src/static.sig new file mode 100644 index 0000000..f809a6d --- /dev/null +++ b/src/static.sig @@ -0,0 +1,30 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature STATIC = sig + +end diff --git a/src/static.sml b/src/static.sml new file mode 100644 index 0000000..c74d4e3 --- /dev/null +++ b/src/static.sml @@ -0,0 +1,41 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Static :> STATIC = struct + +open Settings +open Print.PD Print + +val () = addProtocol {name = "static", + compile = "", + linkStatic = "liburweb_static.a", + linkDynamic = "-lurweb_static", + persistent = false, + code = fn () => box [string "void uw_global_custom() { }", + newline]} + +end diff --git a/src/suffix.mlb b/src/suffix.mlb new file mode 100644 index 0000000..7f2d065 --- /dev/null +++ b/src/suffix.mlb @@ -0,0 +1,2 @@ + +end diff --git a/src/tag.sig b/src/tag.sig new file mode 100644 index 0000000..c19a353 --- /dev/null +++ b/src/tag.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 TAG = sig + + val tag : Core.file -> Core.file + +end diff --git a/src/tag.sml b/src/tag.sml new file mode 100644 index 0000000..94e5d44 --- /dev/null +++ b/src/tag.sml @@ -0,0 +1,356 @@ +(* Copyright (c) 2008, 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 Tag :> TAG = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IM = IntBinaryMap +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +structure UnionFind :> sig + type t + val empty : t + val equate : t * int * int -> t + val equal : t * int * int -> bool + val rep : t * int -> int + end = struct + +type t = int IM.map + +val empty = IM.empty + +fun rep (t, n) = + case IM.find (t, n) of + NONE => n + | SOME n' => rep (t, n') + +fun equate (t, n1, n2) = + let + val r1 = rep (t, n1) + val r2 = rep (t, n2) + in + if r1 = r2 then + t + else + IM.insert (t, r1, r2) + end + +fun equal (t, n1, n2) = rep (t, n1) = rep (t, n2) + +end + +fun kind (k, s) = (k, s) +fun con (c, s) = (c, s) + +fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multiple modes (link, form, RPC handler)."); + TextIO.output (TextIO.stdErr, + "Make sure that the signature of the containing module hides any form/RPC handlers.\n")) + +fun exp uf env (e, s) = + let + fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) = + let + val loc = #2 e + + val eOrig = e + + fun unravel (e, _) = + case e of + ENamed n => (n, []) + | EApp (e1, e2) => + let + val (n, es) = unravel e1 + in + (n, es @ [e2]) + end + | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr + ^ " expression"); + Print.epreface ("Expression", + CorePrint.p_exp env eOrig); + (0, [])) + + val (f, args) = unravel e + in + if f = 0 then + (e, (count, tags, byTag, newTags)) + else + let + val f = UnionFind.rep (uf, f) + + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (ek, f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val (_, _, _, s) = E.lookupENamed env f + + val byTag = case SM.find (byTag, s) of + NONE => SM.insert (byTag, s, (ek, f)) + | SOME (ek', f') => + (if f = f' then + () + else + ErrorMsg.errorAt loc + ("Duplicate HTTP tag " + ^ s); + if ek = ek' then + () + else + both (loc, s); + byTag) + + val e = (EClosure (cn, args), loc) + in + (e, (count, tags, byTag, newTags)) + end + end + in + case e of + EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + useOuter), _), useInner), _), bindOuter), _), bindInner), _), + class), _), + dynClass), _), + style), _), + dynStyle), _), + attrs), _), + tag), _), + xml) => + (case attrs of + (ERecord xets, _) => + let + val (xets, s) = + ListUtil.foldlMap (fn ((x, e, t), s) => + let + fun tagIt' (ek, newAttr) = + let + val (e', s) = tagIt (e, ek, newAttr, s) + val t = (CFfi ("Basis", "string"), loc) + in + (((CName newAttr, loc), e', t), s) + end + in + case x of + (CName "Link", _) => tagIt' (Link ReadCookieWrite, "Link") + | (CName "Action", _) => tagIt' (Action ReadWrite, "Action") + | _ => ((x, e, t), s) + end) + s xets + in + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (EApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + class), loc), dynClass), loc), style), loc), dynStyle), loc), + (ERecord xets, loc)), loc), + tag), loc), + xml), s) + end + | _ => (e, s)) + + | EFfiApp ("Basis", "url", [((ERel 0, _), _)]) => (e, s) + + | EFfiApp ("Basis", "url", [(e, t)]) => + let + val (e, s) = tagIt (e, Link ReadCookieWrite, "Url", s) + in + (EFfiApp ("Basis", "url", [(e, t)]), s) + end + + | EFfiApp ("Basis", "effectfulUrl", [((ERel 0, _), _)]) => (e, s) + + | EFfiApp ("Basis", "effectfulUrl", [(e, t)]) => + let + val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s) + in + (EFfiApp ("Basis", "url", [(e, t)]), s) + end + + | EApp ((ENamed n, _), e') => + let + val (_, _, eo, _) = E.lookupENamed env n + in + case eo of + SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) => + let + val (e, s) = tagIt (e', Link ReadCookieWrite, "Url", s) + in + (EFfiApp ("Basis", "url", [(e, t)]), s) + end + | _ => (e, s) + end + + | _ => (e, s) + end + +fun decl (d, s) = (d, s) + +fun tag file = + let + val count = U.File.maxName file + + fun doDecl (d as (d', loc), (env, count, tags, byTag, uf)) = + case d' of + DExport (ek, n, _) => + let + val (_, _, _, s) = E.lookupENamed env n + in + case SM.find (byTag, s) of + NONE => ([d], (env, count, tags, byTag, uf)) + | SOME (ek', n') => + (if ek = ek' then + () + else + both (loc, s); + ([], (env, count, tags, byTag, uf))) + end + | _ => + let + val env' = E.declBinds env d + val env'' = case d' of + DValRec _ => env' + | _ => env + + val (d, (count, tags, byTag, newTags)) = + U.Decl.foldMap {kind = kind, + con = con, + exp = exp uf env'', + decl = decl} + (count, tags, byTag, []) d + + val env = env' + + val newDs = map + (fn (ek, f, cn) => + let + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + + fun unravel (all as (t, _)) = + case t of + TFun (dom, ran) => + let + val (args, result) = unravel ran + in + (dom :: args, result) + end + | _ => ([], all) + + val (fnam, t, _, tag) = E.lookupENamed env f + val (args, result) = unravel t + + val (abs, t) = + case args of + [] => + let + val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc) + val body = (EWrite app, loc) + in + (body, + (TFun (unit, unit), loc)) + end + | _ => + let + val (app, _) = foldl (fn (t, (app, n)) => + ((EApp (app, (ERel n, loc)), loc), + n - 1)) + ((ENamed f, loc), length args - 1) args + val app = (EApp (app, (ERecord [], loc)), loc) + val body = (EWrite app, loc) + val t = (TFun (unit, unit), loc) + val (abs, _, t) = foldr (fn (t, (abs, n, rest)) => + ((EAbs ("x" ^ Int.toString n, + t, + rest, + abs), loc), + n + 1, + (TFun (t, rest), loc))) + (body, 0, t) args + in + (abs, t) + end + in + (("wrap_" ^ fnam, cn, t, abs, tag), + (DExport (ek, cn, false), loc)) + end) newTags + + val (newVals, newExports) = ListPair.unzip newDs + + val ds = case d of + (DValRec vis, _) => [(DValRec (vis @ newVals), loc)] + | _ => map (fn vi => (DVal vi, loc)) newVals @ [d] + + val uf = case d' of + DVal (_, n1, _, (ENamed n2, _), _) => UnionFind.equate (uf, n1, n2) + | _ => uf + in + (ds @ newExports, (env, count, tags, byTag, uf)) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty, UnionFind.empty) file + in + file + end + +end diff --git a/src/termination.sig b/src/termination.sig new file mode 100644 index 0000000..1de00f1 --- /dev/null +++ b/src/termination.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 TERMINATION = sig + + val check : Elab.file -> unit + +end diff --git a/src/termination.sml b/src/termination.sml new file mode 100644 index 0000000..f0ec46d --- /dev/null +++ b/src/termination.sml @@ -0,0 +1,396 @@ +(* Copyright (c) 2008, 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 Termination :> TERMINATION = struct + +open Elab + +structure E = ElabEnv +structure IM = IntBinaryMap +structure IS = IntBinarySet + +datatype pedigree = + Func of int + | Arg of int * int * con + | Subarg of int * int * con + | Rabble + +fun p2s p = + case p of + Func i => "Func" ^ Int.toString i + | Arg (i, j, _) => "Arg" ^ Int.toString i ^ "," ^ Int.toString j + | Subarg (i, j, _) => "Subarg" ^ Int.toString i ^ "," ^ Int.toString j + | Rabble => "Rabble" + +fun declOk' env (d, loc) = + case d of + DValRec vis => + let + val nfns = length vis + + val fenv = ListUtil.foldli (fn (i, (_, j, _, _), fenv) => IM.insert (fenv, j, i)) IM.empty vis + + fun namesEq ((c1, _), (c2, _)) = + case (c1, c2) of + (CName s1, CName s2) => s1 = s2 + | (CRel n1, CRel n2) => n1 = n2 + | (CNamed n1, CNamed n2) => n1 = n2 + | (CModProj n1, CModProj n2) => n1 = n2 + | _ => false + + fun patCon pc = + let + fun unravel (t, _) = + case t of + TCFun (_, _, _, t) => unravel t + | TFun (dom, _) => dom + | _ => raise Fail "Termination: Unexpected constructor type" + in + case pc of + PConVar i => + let + val (_, t) = E.lookupENamed env i + in + unravel t + end + | PConProj (m1, ms, x) => + let + val (str, sgn) = E.chaseMpath env (m1, ms) + in + case E.projectVal env {str = str, sgn = sgn, field = x} of + NONE => raise Fail "Termination: Bad constructor projection" + | SOME t => unravel t + end + end + + fun pat penv (p, (pt, _)) = + let + fun con (i, j, pc, pt') = pat penv (Subarg (i, j, patCon pc), pt') + + fun record (i, j, t, xps) = + case t of + (TRecord (CRecord (_, xts), _), _) => + foldl (fn ((x, pt', _), penv) => + let + val p' = + case List.find (fn (x', _) => + namesEq ((CName x, ErrorMsg.dummySpan), x')) xts of + NONE => Rabble + | SOME (_, t) => Subarg (i, j, t) + in + pat penv (p', pt') + end) penv xps + | _ => foldl (fn ((_, pt', _), penv) => pat penv (Rabble, pt')) penv xps + in + case (p, pt) of + (_, PVar _) => p :: penv + | (_, PPrim _) => penv + | (_, PCon (_, _, _, NONE)) => penv + | (Arg (i, j, _), PCon (_, pc, _, SOME pt')) => con (i, j, pc, pt') + | (Subarg (i, j, _), PCon (_, pc, _, SOME pt')) => con (i, j, pc, pt') + | (_, PCon (_, _, _, SOME pt')) => pat penv (Rabble, pt') + | (Arg (i, j, t), PRecord xps) => record (i, j, t, xps) + | (Subarg (i, j, t), PRecord xps) => record (i, j, t, xps) + | (_, PRecord xps) => foldl (fn ((_, pt', _), penv) => pat penv (Rabble, pt')) penv xps + end + + fun exp parent (penv, calls) e = + let + val default = (Rabble, calls) + + fun apps () = + let + fun combiner calls e = + case #1 e of + EApp ((ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EModProj (m, [], "tag"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _), _), + (ERecord xets, _)) => + let + val checkName = + case E.lookupStrNamed env m of + ("Basis", _) => (fn x : con => case #1 x of + CName s => s = "Link" + orelse s = "Action" + | _ => false) + | _ => (fn _ => false) + + val calls = foldl (fn ((x, e, _), calls) => + if checkName x then + calls + else + #2 (exp parent (penv, calls) e)) calls xets + in + (Rabble, [Rabble], calls) + end + + | EApp (e1, e2) => + let + val (p1, ps, calls) = combiner calls e1 + val (p2, calls) = exp parent (penv, calls) e2 + + val p = case p1 of + Rabble => Rabble + | Arg _ => Rabble + | Subarg (i, j, (TFun (_, ran), _)) => Subarg (i, j, ran) + | Subarg _ => Rabble + | Func _ => Rabble + in + (p, ps @ [p2], calls) + end + | ECApp (e, _) => + let + val (p, ps, calls) = combiner calls e + + val p = case p of + Rabble => Rabble + | Arg _ => Rabble + | Subarg (i, j, (TCFun (_, _, _, ran), _)) => Subarg (i, j, ran) + | Subarg _ => Rabble + | Func _ => Rabble + in + (p, ps, calls) + end + | EKApp (e, _) => combiner calls e + | _ => + let + val (p, calls) = exp parent (penv, calls) e + in + (*Print.prefaces "Head" [("e", ElabPrint.p_exp env e)]; + print (p2s p ^ "\n");*) + (p, [p], calls) + end + + val (p, ps, calls) = combiner calls e + + val calls = + case ps of + [] => raise Fail "Termination: Empty ps" + | f :: ps => + case f of + Func i => (parent, i, ps) :: calls + | _ => calls + in + (p, calls) + end + in + case #1 e of + EPrim _ => default + | ERel n => (List.nth (penv, n), calls) + | ENamed n => + let + val p = case IM.find (fenv, n) of + NONE => Rabble + | SOME n' => Func n' + in + (p, calls) + end + | EModProj _ => default + + | EApp _ => apps () + | EAbs (_, _, _, e) => + let + val (_, calls) = exp parent (Rabble :: penv, calls) e + in + (Rabble, calls) + end + | ECApp _ => apps () + | ECAbs (_, _, _, e) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end + | EKApp _ => apps () + | EKAbs (_, e) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end + + | ERecord xets => + let + val calls = foldl (fn ((_, e, _), calls) => #2 (exp parent (penv, calls) e)) calls xets + in + (Rabble, calls) + end + | EField (e, x, _) => + let + val (p, calls) = exp parent (penv, calls) e + val p = + case p of + Subarg (i, j, (TRecord (CRecord (_, xts), _), _)) => + (case List.find (fn (x', _) => namesEq (x, x')) xts of + NONE => Rabble + | SOME (_, t) => Subarg (i, j, t)) + | _ => Rabble + in + (p, calls) + end + | ECut (e, _, _) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end + | ECutMulti (e, _, _) => + let + val (_, calls) = exp parent (penv, calls) e + in + (Rabble, calls) + end + | EConcat (e1, _, e2, _) => + let + val (_, calls) = exp parent (penv, calls) e1 + val (_, calls) = exp parent (penv, calls) e2 + in + (Rabble, calls) + end + + | ECase (e, pes, _) => + let + val (p, calls) = exp parent (penv, calls) e + + val calls = foldl (fn ((pt, e), calls) => + let + val penv = pat penv (p, pt) + val (_, calls) = exp parent (penv, calls) e + in + calls + end) calls pes + in + (Rabble, calls) + end + + | EError => (Rabble, calls) + | EUnif (ref (SOME e)) => exp parent (penv, calls) e + | EUnif (ref NONE) => (Rabble, calls) + + | ELet (eds, e, _) => + let + fun extPenv ((ed, _), penv) = + case ed of + EDVal _ => Rabble :: penv + | EDValRec vis => foldl (fn (_, penv) => Rabble :: penv) penv vis + in + exp parent (foldl extPenv penv eds, calls) e + end + end + + fun doVali (i, (_, f, _, e), calls) = + let + fun unravel (e, j, penv) = + case #1 e of + EAbs (_, t, _, e) => + unravel (e, j + 1, Arg (i, j, t) :: penv) + | ECAbs (_, _, _, e) => + unravel (e, j, penv) + | _ => (j, #2 (exp f (penv, calls) e)) + in + unravel (e, 0, []) + end + + val (ns, calls) = ListUtil.foldliMap doVali [] vis + + fun isRecursive (from, to, _) = + let + fun search (at, soFar) = + at = from + orelse List.exists (fn (from', to', _) => + from' = at + andalso not (IS.member (soFar, to')) + andalso search (to', IS.add (soFar, to'))) + calls + in + search (to, IS.empty) + end + + val calls = List.filter isRecursive calls + + fun search (ns, choices) = + case ns of + [] => + let + val choices = rev choices + in + List.all (fn (_, f, args) => + let + val recArg = List.nth (choices, f) + + fun isDatatype (t, _) = + case t of + CNamed _ => true + | CModProj _ => true + | CApp (t, _) => isDatatype t + | _ => false + in + length args > recArg andalso + case List.nth (args, recArg) of + Subarg (i, j, t) => isDatatype t andalso j = List.nth (choices, i) + | _ => false + end) calls + end + | n :: ns' => + let + fun search' i = + i < n andalso (search (ns', i :: choices) orelse search' (i + 1)) + in + search' 0 + end + in + if search (ns, []) then + () + else + ErrorMsg.errorAt loc "Can't prove termination of recursive function(s)" + end + + | DStr (_, _, _, (StrConst ds, _)) => ignore (foldl declOk env ds) + + | _ => () + +and declOk (d, env) = + (declOk' env d; + E.declBinds env d) + +fun check ds = ignore (foldl declOk E.empty ds) + +end diff --git a/src/toy_cache.sml b/src/toy_cache.sml new file mode 100644 index 0000000..5c5aa45 --- /dev/null +++ b/src/toy_cache.sml @@ -0,0 +1,207 @@ +structure ToyCache : sig + val cache : Cache.cache +end = struct + + +(* Mono *) + +open Mono + +val dummyLoc = ErrorMsg.dummySpan +val stringTyp = (TFfi ("Basis", "string"), dummyLoc) +val optionStringTyp = (TOption stringTyp, dummyLoc) +fun withTyp typ = map (fn exp => (exp, typ)) + +fun ffiAppCache' (func, index, argTyps) = + EFfiApp ("Sqlcache", func ^ Int.toString index, argTyps) + +fun check (index, keys) = + ffiAppCache' ("check", index, withTyp stringTyp keys) + +fun store (index, keys, value) = + ffiAppCache' ("store", index, (value, stringTyp) :: withTyp stringTyp keys) + +fun flush (index, keys) = + ffiAppCache' ("flush", index, withTyp optionStringTyp keys) + +fun lock (index, keys) = + raise Fail "ToyCache doesn't yet implement lock" + + +(* Cjr *) + +open Print +open Print.PD + +fun setupQuery {index, params} = + let + + val i = Int.toString index + + fun paramRepeat itemi sep = + let + fun f n = + if n < 0 then "" + else if n = 0 then itemi (Int.toString 0) + else f (n-1) ^ sep ^ itemi (Int.toString n) + in + f (params - 1) + end + + fun paramRepeatInit itemi sep = + if params = 0 then "" else sep ^ paramRepeat itemi sep + + val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", " + + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" + ^ p ^ " = NULL;") + "\n" + + val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p + ^ " = strdup(p" ^ p ^ ");") + "\n" + + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") + "\n" + + val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") + " || " + + (* Using [!=] instead of [==] to mimic [strcmp]. *) + val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || " + ^ "!strcmp(param" ^ i ^ "_" + ^ p ^ ", p" ^ p ^ "))") + " && " + + in + Print.box + [string "static char *cacheQuery", + string i, + string " = NULL;", + newline, + string "static char *cacheWrite", + string i, + string " = NULL;", + newline, + string decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", + string i, + string "(uw_context ctx", + string args, + string ") {", + newline, + string "if (cacheWrite", + string i, + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL", + string eqs, + string ") {", + newline, + string "puts(\"SQLCACHE: miss ", + string i, + string ".\");", + newline, + string "uw_recordingStart(ctx);", + newline, + string "return NULL;", + newline, + string "} else {", + newline, + string "puts(\"SQLCACHE: hit ", + string i, + string ".\");", + newline, + string " if (cacheWrite", + string i, + string " != NULL) { uw_write(ctx, cacheWrite", + string i, + string "); }", + newline, + string "return cacheQuery", + string i, + string ";", + newline, + string "} };", + newline, + string "static uw_unit uw_Sqlcache_store", + string i, + string "(uw_context ctx, uw_Basis_string s", + string args, + string ") {", + newline, + string "free(cacheQuery", + string i, + string "); free(cacheWrite", + string i, + string ");", + newline, + string frees, + newline, + string "cacheQuery", + string i, + string " = strdup(s); cacheWrite", + string i, + string " = uw_recordingRead(ctx);", + newline, + string sets, + newline, + string "puts(\"SQLCACHE: store ", + string i, + string ".\");", + newline, + string "return uw_unit_v;", + newline, + string "};", + newline, + string "static uw_unit uw_Sqlcache_flush", + string i, + string "(uw_context ctx", + string args, + string ") {", + newline, + string "if (cacheQuery", + string i, + string " != NULL", + string eqsNull, + string ") {", + newline, + string "free(cacheQuery", + string i, + string ");", + newline, + string "cacheQuery", + string i, + string " = NULL;", + newline, + string "free(cacheWrite", + string i, + string ");", + newline, + string "cacheWrite", + string i, + string " = NULL;", + newline, + string "puts(\"SQLCACHE: flush ", + string i, + string ".\");}", + newline, + string "else { puts(\"SQLCACHE: keep ", + string i, + string ".\"); } return uw_unit_v;", + newline, + string "};", + newline, + newline] + end + +val setupGlobal = string "/* No global setup for toy cache. */" + + +(* Bundled up. *) + +val cache = {check = check, store = store, flush = flush, lock = lock, + setupQuery = setupQuery, setupGlobal = setupGlobal} + +end diff --git a/src/triple_key_fn.sml b/src/triple_key_fn.sml new file mode 100644 index 0000000..ba77c60 --- /dev/null +++ b/src/triple_key_fn.sml @@ -0,0 +1,15 @@ +functor TripleKeyFn (structure I : ORD_KEY + structure J : ORD_KEY + structure K : ORD_KEY) + : ORD_KEY where type ord_key = I.ord_key * J.ord_key * K.ord_key = struct + +type ord_key = I.ord_key * J.ord_key * K.ord_key + +fun compare ((i1, j1, k1), (i2, j2, k2)) = + case I.compare (i1, i2) of + EQUAL => (case J.compare (j1, j2) of + EQUAL => K.compare (k1, k2) + | ord => ord) + | ord => ord + +end diff --git a/src/tutorial.sig b/src/tutorial.sig new file mode 100644 index 0000000..cda9b01 --- /dev/null +++ b/src/tutorial.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +signature TUTORIAL = sig + + val make : string -> unit + +end diff --git a/src/tutorial.sml b/src/tutorial.sml new file mode 100644 index 0000000..0c2f908 --- /dev/null +++ b/src/tutorial.sml @@ -0,0 +1,322 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Tutorial :> TUTORIAL = struct + +fun readAll inf = + let + fun loop acc = + case TextIO.inputLine inf of + NONE => Substring.full (String.concat (rev acc)) + | SOME line => loop (line :: acc) + in + loop [] + before TextIO.closeIn inf + end + +val readAllFile = readAll o FileIO.txtOpenIn + +fun fixupFile (fname, title) = + let + val source = readAllFile "/tmp/final.html" + val outf = TextIO.openOut (OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (), + path = OS.Path.joinBaseExt {base = OS.Path.base fname, ext = SOME "html"}}) + + val (befor, after) = Substring.position "<title>" source + + fun proseLoop source = + let + val (befor, after) = Substring.splitl (fn ch => ch <> #"&") source + in + if Substring.isEmpty after then + TextIO.outputSubstr (outf, source) + else if Substring.size after >= 4 andalso Substring.string (Substring.slice (after, 1, SOME 3)) = "lt;" then + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, "<"); + proseLoop (Substring.slice (after, 4, NONE))) + else if Substring.size after >= 4 andalso Substring.string (Substring.slice (after, 1, SOME 3)) = "gt;" then + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, ">"); + proseLoop (Substring.slice (after, 4, NONE))) + else if Substring.size after >= 5 andalso Substring.string (Substring.slice (after, 1, SOME 4)) = "amp;" then + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, "&"); + proseLoop (Substring.slice (after, 5, NONE))) + else + raise Fail "Unsupported HTML escape" + end + + fun loop source = + let + val (befor, after) = Substring.position "<span class=\"comment-delimiter\">(* </span><span class=\"comment\">" source + in + if Substring.isEmpty after then + TextIO.outputSubstr (outf, source) + else + let + val (befor', after) = Substring.position " </span><span class=\"comment-delimiter\">*)</span>" + (Substring.slice (after, 64, NONE)) + in + if Substring.isEmpty after then + TextIO.outputSubstr (outf, source) + else + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, "</pre>"); + if Substring.size befor' >= 1 andalso Substring.sub (befor', 0) = #"*" then + (TextIO.output (outf, "<h2>"); + proseLoop (Substring.slice (befor', 2, NONE)); + TextIO.output (outf, "</h2>")) + else + (TextIO.output (outf, "<div class=\"prose\">"); + proseLoop befor'; + TextIO.output (outf, "</div>")); + TextIO.output (outf, "<pre>"); + loop (Substring.slice (after, 49, NONE))) + end + end + in + if Substring.isEmpty after then + raise Fail ("Missing <title> for " ^ title) + else + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, "<style type=\"text/css\">\n"); + TextIO.output (outf, "<!--\n"); + TextIO.output (outf, "\tdiv.prose {\n"); + TextIO.output (outf, "\t\tfont-family: Arial;\n"); + TextIO.output (outf, "\t\tbackground-color: #CCFFCC;\n"); + TextIO.output (outf, "\t\tborder-style: solid;\n"); + TextIO.output (outf, "\t\tpadding: 5px;\n"); + TextIO.output (outf, "\t\tfont-size: larger;\n"); + TextIO.output (outf, "\t}\n"); + TextIO.output (outf, "\th2 {\n"); + TextIO.output (outf, "\t\tfont-family: Arial;\n"); + TextIO.output (outf, "\t\tfont-size: 20pt;\n"); + TextIO.output (outf, "\t\tbackground-color: #99FF99;\n"); + TextIO.output (outf, "\t\tpadding: 5px;\n"); + TextIO.output (outf, "\t}\n"); + TextIO.output (outf, "\ta:link {\n"); + TextIO.output (outf, "\t\ttext-decoration: underline;\n"); + TextIO.output (outf, "\t\tcolor: blue;\n"); + TextIO.output (outf, "\t}\n"); + TextIO.output (outf, "\ta:visited {\n"); + TextIO.output (outf, "\t\ttext-decoration: underline;\n"); + TextIO.output (outf, "\t\tcolor: red;\n"); + TextIO.output (outf, "\t}\n"); + TextIO.output (outf, "-->\n"); + TextIO.output (outf, "</style>\n"); + TextIO.output (outf, "<title>"); + TextIO.output (outf, title); + let + val (befor, after) = Substring.position "</title>" after + in + if Substring.isEmpty after then + raise Fail ("Missing </title> for " ^ title) + else + let + val (befor, after) = Substring.position "<body>" after + in + if Substring.isEmpty after then + raise Fail ("Missing <body> for " ^ title) + else + (TextIO.outputSubstr (outf, befor); + TextIO.output (outf, "<body><h1>"); + TextIO.output (outf, title); + TextIO.output (outf, "</h1>"); + loop (Substring.slice (after, 6, NONE))) + end + end; + TextIO.closeOut outf) + end + +fun doUr fname = + let + val inf = FileIO.txtOpenIn fname + + val title = case TextIO.inputLine inf of + NONE => raise Fail ("No title comment at start of " ^ fname) + | SOME title => title + + val title = String.substring (title, 3, size title - 7) + + val eval = TextIO.openOut "/tmp/eval.ur" + val gen = TextIO.openOut "/tmp/gen.ur" + + fun untilEnd source = + let + val (befor, after) = Substring.position "(* end *)" source + in + if Substring.isEmpty after then + (source, Substring.full "") + else + (befor, Substring.slice (after, 9, NONE)) + end + + fun doDirectives (count, source) = + let + val safe = String.translate (fn #"<" => "<" + | #"&" => "&" + | #"{" => "{" + | #"(" => "(" + | #"\n" => "(*NL*)\n" + | #" " => "(*NL*) " + | ch => str ch) o Substring.string + + val (befor, after) = Substring.position "(* begin " source + + fun default () = (TextIO.outputSubstr (eval, source); + TextIO.output (gen, safe source)) + in + if Substring.isEmpty after then + default () + else + let + val (command, after) = Substring.splitl (not o Char.isSpace) (Substring.slice (after, 9, NONE)) + in + if Substring.isEmpty after then + default () + else + let + val (_, rest) = Substring.position "*)" after + in + if Substring.isEmpty rest then + default () + else + let + val (arg, source) = untilEnd (Substring.slice (rest, 3, NONE)) + val () = (TextIO.outputSubstr (eval, befor); + TextIO.output (gen, safe befor)) + val (count, skip) = + case Substring.string command of + "hide" => (TextIO.outputSubstr (eval, arg); + (count, true)) + | "eval" => (TextIO.output (eval, "val _eval"); + TextIO.output (eval, Int.toString count); + TextIO.output (eval, " = "); + TextIO.outputSubstr (eval, arg); + TextIO.output (eval, "\n\n"); + + TextIO.output (gen, safe arg); + TextIO.output (gen, "== {[_eval"); + TextIO.output (gen, Int.toString count); + TextIO.output (gen, "]}"); + + (count + 1, false)) + | s => raise Fail ("Unknown tutorial directive: " ^ s) + in + doDirectives (count, if skip then + #2 (Substring.splitl Char.isSpace source) + else + source) + end + end + end + end + in + doDirectives (0, readAll inf); + TextIO.closeOut gen; + + TextIO.output (eval, "\n\nfun main () : transaction page =\nreturn <xml><body>"); + TextIO.outputSubstr (eval, readAllFile "/tmp/gen.ur"); + TextIO.output (eval, "</body></xml>"); + TextIO.closeOut eval; + + if Compiler.compile "/tmp/eval" then + let + val proc = Unix.execute ("/bin/sh", ["-c", "/tmp/eval.exe /main"]) + val inf = Unix.textInstreamOf proc + val s = readAll inf + val _ = Unix.reap proc + + val (befor, after) = Substring.position "<body>" s + in + if Substring.isEmpty after then + print ("Bad output for " ^ fname ^ "! [1]\n") + else + let + val after = Substring.slice (after, 6, NONE) + val (befor, after) = Substring.position "</body>" after + in + if Substring.isEmpty after then + print ("Bad output for " ^ fname ^ "! [2]\n") + else + let + val outf = TextIO.openOut "/tmp/final.ur" + + fun eatNls source = + let + val (befor, after) = Substring.position "(*NL*)" source + in + if Substring.isEmpty after then + TextIO.outputSubstr (outf, source) + else + (TextIO.outputSubstr (outf, befor); + eatNls (Substring.slice (after, 6, NONE))) + end + + val cmd = "emacs --eval \"(progn " + ^ "(global-font-lock-mode t) " + ^ "(add-to-list 'load-path \\\"" + ^ !Settings.configSitelisp + ^ "/\\\") " + ^ "(load \\\"urweb-mode-startup\\\") " + ^ "(urweb-mode) " + ^ "(find-file \\\"/tmp/final2.ur\\\") " + ^ "(switch-to-buffer (htmlize-buffer)) " + ^ "(write-file \\\"/tmp/final.html\\\") " + ^ "(kill-emacs))\"" + in + eatNls befor; + TextIO.closeOut outf; + ignore (OS.Process.system "sed -e 's/</</g;s/&/\\&/g' </tmp/final.ur >/tmp/final2.ur"); + ignore (OS.Process.system cmd); + fixupFile (fname, title) + end + end + end + else + () + end + +fun make dirname = + let + val dir = OS.FileSys.openDir dirname + + fun doDir () = + case OS.FileSys.readDir dir of + NONE => OS.FileSys.closeDir dir + | SOME fname => + (if OS.Path.ext fname = SOME "ur" then + doUr (OS.Path.joinDirFile {dir = dirname, file = fname}) + else + (); + doDir ()) + in + Settings.setProtocol "static"; + doDir () + end + +end diff --git a/src/union_find_fn.sml b/src/union_find_fn.sml new file mode 100644 index 0000000..7880591 --- /dev/null +++ b/src/union_find_fn.sml @@ -0,0 +1,58 @@ +functor UnionFindFn(K : ORD_KEY) :> sig + type unionFind + val empty : unionFind + val union : unionFind * K.ord_key * K.ord_key -> unionFind + val union' : (K.ord_key * K.ord_key) * unionFind -> unionFind + val together : unionFind * K.ord_key * K.ord_key -> bool + val classes : unionFind -> K.ord_key list list +end = struct + +structure M = BinaryMapFn(K) +structure S = BinarySetFn(K) + +datatype entry = + Set of S.set + | Pointer of K.ord_key + +(* First map is the union-find tree, second stores equivalence classes. *) +type unionFind = entry M.map ref * S.set M.map + +val empty : unionFind = (ref M.empty, M.empty) + +fun findPair (uf, x) = + case M.find (!uf, x) of + NONE => (S.singleton x, x) + | SOME (Set set) => (set, x) + | SOME (Pointer parent) => + let + val (set, rep) = findPair (uf, parent) + in + uf := M.insert (!uf, x, Pointer rep); + (set, rep) + end + +fun find ((uf, _), x) = (S.listItems o #1 o findPair) (uf, x) + +fun classes (_, cs) = (map S.listItems o M.listItems) cs + +fun together ((uf, _), x, y) = case K.compare (#2 (findPair (uf, x)), #2 (findPair (uf, y))) of + EQUAL => true + | _ => false + +fun union ((uf, cs), x, y) = + let + val (xSet, xRep) = findPair (uf, x) + val (ySet, yRep) = findPair (uf, y) + val xySet = S.union (xSet, ySet) + in + (ref (M.insert (M.insert (!uf, yRep, Pointer xRep), + xRep, Set xySet)), + M.insert (case M.find (cs, yRep) of + NONE => cs + | SOME _ => #1 (M.remove (cs, yRep)), + xRep, xySet)) + end + +fun union' ((x, y), uf) = union (uf, x, y) + +end diff --git a/src/unnest.sig b/src/unnest.sig new file mode 100644 index 0000000..6508a78 --- /dev/null +++ b/src/unnest.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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. + *) + +(* Remove nested function definitions *) + +signature UNNEST = sig + + val unnest : Elab.file -> Elab.file + +end diff --git a/src/unnest.sml b/src/unnest.sml new file mode 100644 index 0000000..7469ffd --- /dev/null +++ b/src/unnest.sml @@ -0,0 +1,567 @@ +(* 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. + *) + +(* Remove nested function definitions *) + +structure Unnest :> UNNEST = struct + +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +structure IS = IntBinarySet + +fun liftExpInExp by = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + by) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {kind = fn _ => fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + if xn' = xn then + #1 rep + else + e + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, E.liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep) + | (ctx, _) => ctx} + +val fvsKind = U.Kind.foldB {kind = fn (kb, k, kvs) => + case k of + KRel n => + if n >= kb then + IS.add (kvs, n - kb) + else + kvs + | _ => kvs, + bind = fn (kb, b) => kb + 1} + 0 IS.empty + +val fvsCon = U.Con.foldB {kind = fn ((kb, _), k, st as (kvs, cvs)) => + case k of + KRel n => + if n >= kb then + (IS.add (kvs, n - kb), cvs) + else + st + | _ => st, + con = fn ((_, cb), c, st as (kvs, cvs)) => + case c of + CRel n => + if n >= cb then + (kvs, IS.add (cvs, n - cb)) + else + st + | _ => st, + bind = fn (ctx as (kb, cb), b) => + case b of + U.Con.RelK _ => (kb + 1, cb + 1) + | U.Con.RelC _ => (kb, cb + 1) + | _ => ctx} + (0, 0) (IS.empty, IS.empty) + +fun fvsExp nr = U.Exp.foldB {kind = fn ((kb, _, _), k, st as (kvs, cvs, evs)) => + case k of + KRel n => + if n >= kb then + (IS.add (kvs, n - kb), cvs, evs) + else + st + | _ => st, + con = fn ((kb, cb, eb), c, st as (kvs, cvs, evs)) => + case c of + CRel n => + if n >= cb then + (kvs, IS.add (cvs, n - cb), evs) + else + st + | _ => st, + exp = fn ((kb, cb, eb), e, st as (kvs, cvs, evs)) => + case e of + ERel n => + if n >= eb then + (kvs, cvs, IS.add (evs, n - eb)) + else + st + | _ => st, + bind = fn (ctx as (kb, cb, eb), b) => + case b of + U.Exp.RelK _ => (kb + 1, cb, eb) + | U.Exp.RelC _ => (kb, cb + 1, eb) + | U.Exp.RelE _ => (kb, cb, eb + 1) + | _ => ctx} + (0, 0, nr) (IS.empty, IS.empty, IS.empty) + +fun positionOf (x : int) ls = + let + fun po n ls = + case ls of + [] => raise Fail "Unnest.positionOf" + | x' :: ls' => + if x' = x then + n + else + po (n + 1) ls' + in + po 0 ls + handle Fail _ => raise Fail ("Unnest.positionOf(" + ^ Int.toString x + ^ ", " + ^ String.concatWith ";" (map Int.toString ls) + ^ ")") + end + +fun squishCon (kfv, cfv) = + U.Con.mapB {kind = fn (kb, _) => fn k => + case k of + KRel n => + if n >= kb then + KRel (positionOf (n - kb) kfv + kb) + else + k + | _ => k, + con = fn (_, cb) => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + bind = fn (ctx as (kb, cb), b) => + case b of + U.Con.RelK _ => (kb + 1, cb) + | U.Con.RelC _ => (kb, cb + 1) + | _ => ctx} + (0, 0) + +fun squishExp (nr, kfv, cfv, efv) = + U.Exp.mapB {kind = fn (kb, _, _) => fn k => + case k of + KRel n => + if n >= kb then + KRel (positionOf (n - kb) kfv + kb) + else + k + | _ => k, + con = fn (_, cb, _) => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + exp = fn (_, _, eb) => fn e => + case e of + ERel n => + if n >= eb then + ERel (positionOf (n - eb) efv + eb - nr) + else + e + | _ => e, + bind = fn (ctx as (kb, cb, eb), b) => + case b of + U.Exp.RelK _ => (kb + 1, cb, eb) + | U.Exp.RelC _ => (kb, cb + 1, eb) + | U.Exp.RelE _ => (kb, cb, eb + 1) + | _ => ctx} + (0, 0, nr) + +type state = { + maxName : int, + decls : (string * int * con * exp) list +} + +fun kind (_, k, st) = (k, st) + +val basis = ref 0 + +fun exp ((ns, ks, ts), e as old, st : state) = + case e of + ELet (eds, e, t) => + let + (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) + + fun doSubst' (e, subs) = foldl (fn (p, e) => subExpInExp p e) e subs + + fun doSubst (e, subs, by) = + let + val e = doSubst' (e, subs) + in + liftExpInExp (~by) (length subs) e + end + + fun functionInside (t : con) = + case #1 t of + TFun _ => true + | CApp ((CModProj (basis', [], "transaction"), _), _) => basis' = !basis + | _ => false + + val eds = map (fn ed => + case #1 ed of + EDVal ((PVar (x, _), _), t, e) => + if functionInside t then + (EDValRec [(x, t, E.liftExpInExp 0 e)], #2 ed) + else + ed + | _ => ed) eds + + val (eds, (ts, maxName, ds, subs, by)) = + ListUtil.foldlMapConcat + (fn (ed, (ts, maxName, ds, subs, by)) => + case #1 ed of + EDVal (p, t, e) => + let + val e = doSubst (e, subs, by) + + fun doVars ((p, _), ts) = + case p of + PVar xt => xt :: ts + | PPrim _ => ts + | PCon (_, _, _, NONE) => ts + | PCon (_, _, _, SOME p) => doVars (p, ts) + | PRecord xpcs => + foldl (fn ((_, p, _), ts) => doVars (p, ts)) + ts xpcs + + fun bindOne subs = ((0, (ERel 0, #2 ed)) + :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs) + + fun bindMany (n, subs) = + case n of + 0 => subs + | _ => bindMany (n - 1, bindOne subs) + in + ([(EDVal (p, t, e), #2 ed)], + (doVars (p, ts), + maxName, ds, + bindMany (E.patBindsN p, subs), + by)) + end + | EDValRec vis => + let + val loc = #2 ed + + val nr = length vis + val subsLocal = List.filter (fn (_, (ERel _, _)) => false + | _ => true) subs + val subsLocal = map (fn (n, e) => (n + nr, liftExpInExp nr 0 e)) + subsLocal + + val vis = map (fn (x, t, e) => + (x, t, doSubst' (e, subsLocal))) vis + + val (kfv, cfv, efv) = + foldl (fn ((_, t, e), (kfv, cfv, efv)) => + let + val (kfv', cfv', efv') = fvsExp nr e + (*val () = Print.prefaces "fvsExp" + [("e", ElabPrint.p_exp E.empty e), + ("cfv", Print.PD.string + (Int.toString (IS.numItems cfv'))), + ("efv", Print.PD.string + (Int.toString (IS.numItems efv')))]*) + val (kfv'', cfv'') = fvsCon t + in + (IS.union (kfv, IS.union (kfv', kfv'')), + IS.union (cfv, IS.union (cfv', cfv'')), + IS.union (efv, efv')) + end) + (IS.empty, IS.empty, IS.empty) vis + + (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + (*val () = app (fn (x, t) => + Print.prefaces "Var" [("x", Print.PD.string x), + ("t", ElabPrint.p_con E.empty t)]) ts + val () = IS.app (fn n => print ("Free: " ^ Int.toString n ^ "\n")) efv*) + + val kfv = IS.foldl (fn (x, kfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, k) = List.nth (ks, x) + in + IS.union (kfv, fvsKind k) + end) + kfv cfv + + val kfv = IS.foldl (fn (x, kfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, t) = List.nth (ts, x) + in + IS.union (kfv, #1 (fvsCon t)) + end) + kfv efv + + val cfv = IS.foldl (fn (x, cfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, t) = List.nth (ts, x) + in + IS.union (cfv, #2 (fvsCon t)) + end) + cfv efv + (*val () = print "B\n"*) + + val (vis, maxName) = + ListUtil.foldlMap (fn ((x, t, e), maxName) => + ((x, maxName, t, e), + maxName + 1)) + maxName vis + + val subs = map (fn (n, e) => (n + nr, + case e of + (ERel _, _) => e + | _ => liftExpInExp nr 0 e)) + subs + + val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => + let + val e = (ENamed n, loc) + + val e = IS.foldr (fn (x, e) => + (EKApp (e, (KRel x, loc)), loc)) + e kfv + + val e = IS.foldr (fn (x, e) => + (ECApp (e, (CRel x, loc)), loc)) + e cfv + + val e = IS.foldr (fn (x, e) => + (EApp (e, (ERel (nr + x), loc)), + loc)) + e efv + in + (nr - i - 1, e) + end) + vis + + val kfv = IS.listItems kfv + val cfv = IS.listItems cfv + val efv = IS.listItems efv + + val subs = subs' @ subs + + val vis = map (fn (x, n, t, e) => + let + (*val () = Print.prefaces "preSubst" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = doSubst' (e, subs') + + (*val () = Print.prefaces "squishCon" + [("t", ElabPrint.p_con E.empty t)]*) + val t = squishCon (kfv, cfv) t + (*val () = Print.prefaces "squishExp" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = squishExp (nr, kfv, cfv, efv) e + + (*val () = print ("Avail: " ^ Int.toString (length ts) ^ "\n")*) + val (e, t) = foldl (fn (ex, (e, t)) => + let + (*val () = print (Int.toString ex ^ "\n")*) + val (name, t') = List.nth (ts, ex) + val t' = squishCon (kfv, cfv) t' + in + ((EAbs (name, + t', + t, + e), loc), + (TFun (t', + t), loc)) + end) + (e, t) efv + (*val () = print "Done\n"*) + + val (e, t) = foldl (fn (cx, (e, t)) => + let + val (name, k) = List.nth (ks, cx) + in + ((ECAbs (Explicit, + name, + k, + e), loc), + (TCFun (Explicit, + name, + k, + t), loc)) + end) + (e, t) cfv + + val (e, t) = foldl (fn (kx, (e, t)) => + let + val name = List.nth (ns, kx) + in + ((EKAbs (name, + e), loc), + (TKFun (name, + t), loc)) + end) + (e, t) kfv + in + (*Print.prefaces "Have a vi" + [("x", Print.PD.string x), + ("e", ElabPrint.p_exp ElabEnv.empty e)];*) + ("$" ^ x, n, t, e) + end) + vis + + val ts = List.revAppend (map (fn (x, _, t, _) => (x, t)) vis, ts) + in + ([], (ts, maxName, vis @ ds, subs, by + nr)) + end) + (ts, #maxName st, #decls st, [], 0) eds + + val e' = doSubst (e, subs, by) + in + (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e), + ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))), + ("e'", ElabPrint.p_exp ElabEnv.empty e')];*) + (*Print.prefaces "Let" [("Before", ElabPrint.p_exp ElabEnv.empty (old, ErrorMsg.dummySpan)), + ("After", ElabPrint.p_exp ElabEnv.empty (ELet (eds, e', t), ErrorMsg.dummySpan))];*) + (ELet (eds, e', t), + {maxName = maxName, + decls = ds}) + (*(ELet (eds, doSubst (liftExpInExp (~(length subs - numRemaining)) (length subs) e) subs),*) + end + + | _ => (e, st) + +fun default (ctx, d, st) = (d, st) + +fun bind ((ns, ks, ts), b) = + case b of + U.Decl.RelK x => (x :: ns, ks, ts) + | U.Decl.RelC p => (ns, p :: ks, map (fn (name, t) => (name, E.liftConInCon 0 t)) ts) + | U.Decl.RelE p => (ns, ks, p :: ts) + | _ => (ns, ks, ts) + +val unnestDecl = U.Decl.foldMapB {kind = kind, + con = default, + exp = exp, + sgn_item = default, + sgn = default, + str = default, + decl = default, + bind = bind} + ([], [], []) + +fun unnest file = + let + fun doDecl (all as (d, loc), st : state) = + let + fun default () = ([all], st) + fun explore () = + let + val (d, st) = unnestDecl st all + + val ds = + case #1 d of + DValRec vis => [(DValRec (vis @ #decls st), #2 d)] + | _ => [(DValRec (#decls st), #2 d), d] + in + (ds, + {maxName = #maxName st, + decls = []}) + end + in + case d of + DCon _ => default () + | DDatatype _ => default () + | DDatatypeImp _ => default () + | DVal _ => explore () + | DValRec _ => explore () + | DSgn _ => default () + | DStr (x, n, sgn, str) => + let + val (str, st) = doStr (str, st) + in + ([(DStr (x, n, sgn, str), loc)], st) + end + | DFfiStr ("Basis", n, _) => (basis := n; default ()) + | DFfiStr _ => default () + | DConstraint _ => default () + | DExport _ => default () + | DTable _ => default () + | DSequence _ => default () + | DView _ => default () + | DDatabase _ => default () + | DCookie _ => default () + | DStyle _ => default () + | DTask _ => explore () + | DPolicy _ => explore () + | DOnError _ => default () + | DFfi _ => default () + end + + and doStr (all as (str, loc), st) = + let + fun default () = (all, st) + in + case str of + StrConst ds => + let + val (ds, st) = ListUtil.foldlMapConcat doDecl st ds + in + ((StrConst ds, loc), st) + end + | StrVar _ => default () + | StrProj _ => default () + | StrFun (x, n, dom, ran, str) => + let + val (str, st) = doStr (str, st) + in + ((StrFun (x, n, dom, ran, str), loc), st) + end + | StrApp _ => default () + | StrError => raise Fail "Unnest: StrError" + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + decls = []} file + in + ds + end + +end diff --git a/src/unpoly.sig b/src/unpoly.sig new file mode 100644 index 0000000..aba3825 --- /dev/null +++ b/src/unpoly.sig @@ -0,0 +1,34 @@ +(* Copyright (c) 2008, 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. + *) + +(* Simplify a Core program by repeating polymorphic function definitions *) + +signature UNPOLY = sig + + val unpoly : Core.file -> Core.file + +end diff --git a/src/unpoly.sml b/src/unpoly.sml new file mode 100644 index 0000000..549de5d --- /dev/null +++ b/src/unpoly.sml @@ -0,0 +1,336 @@ +(* 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. + *) + +(* Simplify a Core program by repeating polymorphic function definitions *) + +structure Unpoly :> UNPOLY = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure IS = IntBinarySet +structure IM = IntBinaryMap + + +(** The actual specialization *) + +val liftConInCon = E.liftConInCon +val subConInCon = E.subConInCon + +val liftConInExp = E.liftConInExp +val subConInExp = E.subConInExp + +val isOpen = U.Con.existsB {kind = fn _ => false, + con = fn (n, c) => + case c of + CRel n' => n' >= n + | _ => false, + bind = fn (n, b) => + case b of + U.Con.RelC _ => n + 1 + | _ => n} 0 + +fun unpolyNamed (xn, rep) = + U.Exp.map {kind = fn k => k, + con = fn c => c, + exp = fn e => + case e of + ECApp (e', _) => + let + fun isTheOne (e, _) = + case e of + ENamed xn' => xn' = xn + | ECApp (e, _) => isTheOne e + | _ => false + in + if isTheOne e' then + rep + else + e + end + | _ => e} + +structure M = BinaryMapFn(struct + type ord_key = con list + val compare = Order.joinL U.Con.compare + end) + +type func = { + kinds : kind list, + defs : (string * int * con * exp * string) list, + replacements : int M.map +} + +type state = { + funcs : func IM.map, + decls : decl list, + nextName : int +} + +fun kind (k, st) = (k, st) + +fun con (c, st) = (c, st) + +fun exp (e, st : state) = + case e of + ECApp _ => + let + fun unravel (e, cargs) = + case e of + ECApp ((e, _), c) => unravel (e, c :: cargs) + | ENamed n => SOME (n, rev cargs) + | _ => NONE + in + case unravel (e, []) of + NONE => (e, st) + | SOME (n, cargs) => + if List.exists isOpen cargs then + (e, st) + else + case IM.find (#funcs st, n) of + NONE => (e, st) + | SOME {kinds = ks, defs = vis, replacements} => + let + val cargs = map ReduceLocal.reduceCon cargs + in + case M.find (replacements, cargs) of + SOME n => (ENamed n, st) + | NONE => + let + val old_vis = vis + val (vis, (thisName, nextName)) = + ListUtil.foldlMap + (fn ((x, n', t, e, s), (thisName, nextName)) => + ((x, nextName, n', t, e, s), + (if n' = n then nextName else thisName, + nextName + 1))) + (0, #nextName st) vis + + fun specialize (x, n, n_old, t, e, s) = + let + fun trim (t, e, cargs) = + case (t, e, cargs) of + ((TCFun (_, _, t), _), + (ECAbs (_, _, e), _), + carg :: cargs) => + let + val t = subConInCon (length cargs, carg) t + val e = subConInExp (length cargs, carg) e + in + trim (t, e, cargs) + end + | (_, _, []) => SOME (t, e) + | _ => NONE + in + (*Print.prefaces "specialize" + [("n", Print.PD.string (Int.toString n)), + ("nold", Print.PD.string (Int.toString n_old)), + ("t", CorePrint.p_con CoreEnv.empty t), + ("e", CorePrint.p_exp CoreEnv.empty e), + ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*) + Option.map (fn (t, e) => (x, n, n_old, t, e, s)) + (trim (t, e, cargs)) + end + + val vis = List.map specialize vis + in + if List.exists (not o Option.isSome) vis orelse length cargs > length ks then + (e, st) + else + let + val vis = List.mapPartial (fn x => x) vis + + val vis = map (fn (x, n, n_old, t, e, s) => + (x ^ "_unpoly", n, n_old, t, e, s)) vis + val vis' = map (fn (x, n, _, t, e, s) => + (x, n, t, e, s)) vis + + val funcs = foldl (fn ((_, n, n_old, _, _, _), funcs) => + let + val replacements = case IM.find (funcs, n_old) of + NONE => M.empty + | SOME {replacements = r, + ...} => r + in + IM.insert (funcs, n_old, + {kinds = ks, + defs = old_vis, + replacements = M.insert (replacements, + cargs, + n)}) + end) (#funcs st) vis + + val ks' = List.drop (ks, length cargs) + + val st = {funcs = foldl (fn (vi, funcs) => + IM.insert (funcs, #2 vi, + {kinds = ks', + defs = vis', + replacements = M.empty})) + funcs vis', + decls = #decls st, + nextName = nextName} + + val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => + let + val (e, st) = polyExp (e, st) + in + ((x, n, t, e, s), st) + end) + st vis' + in + (ENamed thisName, + {funcs = #funcs st, + decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st, + nextName = #nextName st}) + end + end + end + end + | _ => (e, st) + +and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x + +fun decl (d, st : state) = + let + fun unravel (e, cargs) = + case e of + (ECAbs (_, k, e), _) => + unravel (e, k :: cargs) + | _ => rev cargs + in + case d of + DVal (vi as (x, n, t, e, s)) => + let + val cargs = unravel (e, []) + + val ns = IS.singleton n + in + (d, {funcs = IM.insert (#funcs st, n, {kinds = cargs, + defs = [vi], + replacements = M.empty}), + decls = #decls st, + nextName = #nextName st}) + end + | DValRec (vis as ((x, n, t, e, s) :: rest)) => + let + val cargs = unravel (e, []) + + fun unravel (e, cargs) = + case (e, cargs) of + ((ECAbs (_, k, e), _), k' :: cargs) => + U.Kind.compare (k, k') = EQUAL + andalso unravel (e, cargs) + | (_, []) => true + | _ => false + + fun deAbs (e, cargs) = + case (e, cargs) of + ((ECAbs (_, _, e), _), _ :: cargs) => deAbs (e, cargs) + | (_, []) => e + | _ => raise Fail "Unpoly: deAbs" + + in + if List.exists (fn vi => not (unravel (#4 vi, cargs))) rest then + (d, st) + else + let + val ns = IS.addList (IS.empty, map #2 vis) + val nargs = length cargs + + (** Verifying lack of polymorphic recursion *) + + fun kind _ = false + fun con _ = false + + fun exp (cn, e) = + case e of + orig as ECApp (e, c) => + let + fun isIrregular (e, pos) = + case #1 e of + ENamed n => + IS.member (ns, n) + andalso + (case #1 c of + CRel i => i <> nargs - pos + cn + | _ => true) + | ECApp (e, _) => isIrregular (e, pos + 1) + | _ => false + in + isIrregular (e, 1) + end + | _ => false + + fun bind (cn, b) = + case b of + U.Exp.RelC _ => cn+1 + | _ => cn + + val irregular = U.Exp.existsB {kind = kind, con = con, exp = exp, bind = bind} 0 + in + if List.exists (fn x => irregular (deAbs (#4 x, cargs))) vis then + (d, st) + else + (d, {funcs = foldl (fn (vi, funcs) => + IM.insert (funcs, #2 vi, {kinds = cargs, + defs = vis, + replacements = M.empty})) + (#funcs st) vis, + decls = #decls st, + nextName = #nextName st}) + end + end + + | _ => (d, st) + end + +val polyDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} + +fun unpoly file = + let + fun doDecl (d : decl, st : state) = + let + val (d, st) = polyDecl st d + in + (rev (d :: #decls st), + {funcs = #funcs st, + decls = [], + nextName = #nextName st}) + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {funcs = IM.empty, + decls = [], + nextName = U.File.maxName file + 1} file + in + ds + end + +end diff --git a/src/untangle.sig b/src/untangle.sig new file mode 100644 index 0000000..522cc6d --- /dev/null +++ b/src/untangle.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 UNTANGLE = sig + + val untangle : Mono.file -> Mono.file + +end diff --git a/src/untangle.sml b/src/untangle.sml new file mode 100644 index 0000000..bcb90ed --- /dev/null +++ b/src/untangle.sml @@ -0,0 +1,214 @@ +(* Copyright (c) 2008, 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 Untangle :> UNTANGLE = struct + +open Mono + +structure U = MonoUtil +structure E = MonoEnv + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun typ (k, s) = s + +fun exp (e, s) = + case e of + ENamed n => IS.add (s, n) + + | _ => s + +fun untangle (file : file) = + let + fun decl (dAll as (d, loc)) = + case d of + DValRec vis => + let + val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => + IS.add (thisGroup, n)) IS.empty vis + + val used = foldl (fn ((_, n, _, e, _), used) => + let + val usedHere = U.Exp.fold {typ = typ, + exp = exp} IS.empty e + in + IM.insert (used, n, IS.intersection (usedHere, thisGroup)) + end) + IM.empty vis + + fun p_graph reachable = + IM.appi (fn (n, reachableHere) => + (print (Int.toString n); + print ":"; + IS.app (fn n' => (print " "; + print (Int.toString n'))) reachableHere; + print "\n")) reachable + + (*val () = print "used:\n" + val () = p_graph used*) + + fun expand reachable = + let + val changed = ref false + + val reachable = + IM.mapi (fn (n, reachableHere) => + IS.foldl (fn (n', reachableHere) => + let + val more = valOf (IM.find (reachable, n')) + in + if IS.isEmpty (IS.difference (more, reachableHere)) then + reachableHere + else + (changed := true; + IS.union (more, reachableHere)) + end) + reachableHere reachableHere) reachable + in + (reachable, !changed) + end + + fun iterate reachable = + let + val (reachable, changed) = expand reachable + in + if changed then + iterate reachable + else + reachable + end + + val reachable = iterate used + + (*val () = print "reachable:\n" + val () = p_graph reachable*) + + fun sccs (nodes, acc) = + case IS.find (fn _ => true) nodes of + NONE => acc + | SOME rep => + let + val reachableHere = valOf (IM.find (reachable, rep)) + + val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) => + if node = rep then + (nodes, scc) + else + let + val reachableThere = + valOf (IM.find (reachable, node)) + in + if IS.member (reachableThere, rep) then + (IS.delete (nodes, node), + IS.add (scc, node)) + else + (nodes, scc) + end) + (IS.delete (nodes, rep), IS.singleton rep) reachableHere + in + sccs (nodes, scc :: acc) + end + + val sccs = sccs (thisGroup, []) + (*val () = app (fn nodes => (print "SCC:"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) + (*val () = app (fn nodes => (print "SCC':"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun isNonrec nodes = + case IS.find (fn _ => true) nodes of + NONE => NONE + | SOME node => + let + val nodes = IS.delete (nodes, node) + val reachableHere = valOf (IM.find (reachable, node)) + in + if IS.isEmpty nodes then + if IS.member (reachableHere, node) then + NONE + else + SOME node + else + NONE + end + + val ds = map (fn nodes => + case isNonrec nodes of + SOME node => + let + val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis) + in + (DVal vi, loc) + end + | NONE => + (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc)) + sccs + in + ds + end + | _ => [dAll] + in + (ListUtil.mapConcat decl (#1 file), #2 file) + end + +end diff --git a/src/urweb.grm b/src/urweb.grm new file mode 100644 index 0000000..afebff0 --- /dev/null +++ b/src/urweb.grm @@ -0,0 +1,2394 @@ +(* Copyright (c) 2008-2016, 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 SOFTARE 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. + *) + +(* Grammar for Ur/Web programs *) + +open Source + +val s = ErrorMsg.spanOf +val dummy = ErrorMsg.dummySpan + +fun capitalize "" = "" + | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun makeAttr s = + case s of + "type" => "Typ" + | "name" => "Nam" + | _ => capitalize (String.translate (fn ch => if ch = #"-" then "_" else str ch) s) + +fun entable t = + case #1 t of + TRecord c => c + | _ => t + +datatype select_item = + Field of con * con + | Exp of con option * exp + | Fields of con * con + | StarFields of con + +datatype select = + Star + | Items of select_item list + +datatype group_item = + GField of con * con + | GFields of con * con + +fun eqTnames ((c1, _), (c2, _)) = + case (c1, c2) of + (CVar (ms1, x1), CVar (ms2, x2)) => ms1 = ms2 andalso x1 = x2 + | (CName x1, CName x2) => x1 = x2 + | _ => false + +fun nameString (c, _) = + case c of + CName s => s + | CVar (_, x) => x + | _ => "?" + +datatype tableMode = + Unknown + | Everything + | Selective of con + +fun amend_select loc (si, (count, tabs, exps)) = + case si of + Field (tx, fx) => + let + val c = (CRecord ([(fx, (CWild (KType, loc), loc))]), loc) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + case c' of + Everything => + (ErrorMsg.errorAt loc + "Mixing specific-field and '*' selection of fields from same table"; + ((tx', c'), found)) + | Unknown => + ((tx', Selective c), true) + | Selective c' => + ((tx', Selective (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc ("Select of field " ^ nameString fx ^ " from unbound table " ^ nameString tx); + + (count, tabs, exps) + end + | Fields (tx, fs) => + let + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + case c' of + Everything => + (ErrorMsg.errorAt loc + "Mixing specific-field and '*' selection of fields from same table"; + ((tx', c'), found)) + | Selective c' => + ((tx', Selective (CConcat (fs, c'), loc)), true) + | Unknown => + ((tx', Selective fs), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + (count, tabs, exps) + end + | StarFields tx => + if List.exists (fn (tx', c') => eqTnames (tx, tx') andalso case c' of + Unknown => false + | _ => true) tabs then + (ErrorMsg.errorAt loc "Selection with '*' from table already mentioned in same SELECT clause"; + (count, tabs, exps)) + else if List.all (fn (tx', c') => not (eqTnames (tx, tx'))) tabs then + (ErrorMsg.errorAt loc "Select of all fields from unbound table"; + (count, tabs, exps)) + else + (count, map (fn (tx', c') => (tx', if eqTnames (tx, tx') then Everything else c')) tabs, exps) + | Exp (SOME c, e) => (count, tabs, (c, e) :: exps) + | Exp (NONE, e) => (count+1, tabs, ((CName (Int.toString count), loc), e) :: exps) + +fun amend_group loc (gi, tabs) = + let + val (tx, c) = case gi of + GField (tx, fx) => (tx, (CRecord ([(fx, (CWild (KType, loc), loc))]), loc)) + | GFields (tx, fxs) => (tx, fxs) + + val (tabs, found) = ListUtil.foldlMap (fn ((tx', c'), found) => + if eqTnames (tx, tx') then + ((tx', (CConcat (c, c'), loc)), true) + else + ((tx', c'), found)) + false tabs + in + if found then + () + else + ErrorMsg.errorAt loc "Select of field from unbound table"; + + tabs + end + +fun sql_inject (v, loc) = + (EApp ((EVar (["Basis"], "sql_inject", Infer), loc), (v, loc)), loc) + +fun sql_binary (oper, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_binary", Infer), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_unary (oper, sqlexp, loc) = + let + val e = (EVar (["Basis"], "sql_unary", Infer), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) + in + (EApp (e, sqlexp), loc) + end + +fun sql_relop (oper, all, sqlexp1, sqlexp2, loc) = + let + val e = (EVar (["Basis"], "sql_relop", Infer), loc) + val e = (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) + val e = (EApp (e, (EVar (["Basis"], if all then "True" else "False", Infer), loc)), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end + +fun sql_nfunc (oper, loc) = + let + val e = (EVar (["Basis"], "sql_nfunc", Infer), loc) + in + (EApp (e, (EVar (["Basis"], "sql_" ^ oper, Infer), loc)), loc) + end + +fun native_unop (oper, e1, loc) = + let + val e = (EVar (["Basis"], oper, Infer), loc) + in + (EApp (e, e1), loc) + end + +fun native_op (oper, e1, e2, loc) = + let + val e = (EVar (["Basis"], oper, Infer), loc) + val e = (EApp (e, e1), loc) + in + (EApp (e, e2), loc) + end + +fun top_binop (oper, e1, e2, loc) = + let + val e = (EVar (["Top"], oper, Infer), loc) + val e = (EApp (e, e1), loc) + in + (EApp (e, e2), loc) + end + +val inDml = ref false + +fun tagIn bt = + case bt of + "table" => "tabl" + | "url" => "url_" + | "datetime-local" => "datetime_local" + | "cdatetime-local" => "cdatetime_local" + | _ => bt + +datatype prop_kind = Delete | Update + +datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * string * exp + +fun patType loc (p : pat) = + case #1 p of + PAnnot (_, t) => t + | _ => (CWild (KType, loc), loc) + +fun tnamesOf (e, _) = + case e of + EApp (e1, e2) => tnamesOf e1 @ tnamesOf e2 + | ECApp (e, c as (CName _, _)) => + let + fun isFt (e, _) = + case e of + EVar (["Basis"], "sql_from_table", _) => true + | EVar ([], "sql_from_table", _) => true + | ECApp (e, _) => isFt e + | EApp (e, _) => isFt e + | EDisjointApp e => isFt e + | _ => false + in + (if isFt e then [c] else []) @ tnamesOf e + end + | ECApp (e, _) => tnamesOf e + | EDisjointApp e => tnamesOf e + | _ => [] + +fun classOut (s, pos) = + let + val s = case s of + "table" => "tabl" + | _ => s + in + (EVar ([], String.translate (fn #"-" => "_" | ch => str ch) s, Infer), pos) + end + +fun parseClass s pos = + case String.tokens Char.isSpace s of + [] => (EVar (["Basis"], "null", Infer), pos) + | class :: classes => + foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos)) + (classOut (class, pos)) classes + +fun parseValue s pos = + if String.isPrefix "url(" s andalso String.isSuffix ")" s then + let + val s = String.substring (s, 4, size s - 5) + + val s = if size s >= 2 + andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s) + orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then + String.substring (s, 1, size s - 2) + else + s + in + (EApp ((EVar (["Basis"], "css_url", Infer), pos), + (EApp ((EVar (["Basis"], "bless", Infer), pos), + (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)), pos) + end + else + (EApp ((EVar (["Basis"], "atom", Infer), pos), + (EPrim (Prim.String (Prim.Normal, s)), pos)), pos) + +fun parseProperty s pos = + let + val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s) + in + if Substring.isEmpty after then + (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); + (EPrim (Prim.String (Prim.Normal, "")), pos)) + else + foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) + (EApp ((EVar (["Basis"], "property", Infer), pos), + (EPrim (Prim.String (Prim.Normal, Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) + (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) + end + +fun parseStyle s pos = + case String.tokens (fn ch => ch = #";") s of + [] => (EVar (["Basis"], "noStyle", Infer), pos) + | props => + foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos)) + (EVar (["Basis"], "noStyle", Infer), pos) props + +fun applyWindow loc e window = + let + val (pb, ob) = getOpt (window, ((EVar (["Basis"], "sql_no_partition", Infer), dummy), + (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy), + (CWild (KRecord (KType, dummy), dummy), dummy)), + dummy))) + val e' = (EVar (["Basis"], "sql_window_function", Infer), loc) + val e' = (EApp (e', e), loc) + val e' = (EApp (e', pb), loc) + in + (EApp (e', ob), loc) + end + +fun patternOut (e : exp) = + case #1 e of + EWild => (PVar "_", #2 e) + | EVar ([], x, Infer) => + if Char.isUpper (String.sub (x, 0)) then + (PCon ([], x, NONE), #2 e) + else + (PVar x, #2 e) + | EVar (xs, x, Infer) => + if Char.isUpper (String.sub (x, 0)) then + (PCon (xs, x, NONE), #2 e) + else + (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern"; + (PVar "_", #2 e)) + | EPrim p => (PPrim p, #2 e) + | EApp ((EVar (xs, x, Infer), _), e') => + (PCon (xs, x, SOME (patternOut e')), #2 e) + | ERecord (xes, flex) => + (PRecord (map (fn (x, e') => + let + val x = + case #1 x of + CName x => x + | _ => (ErrorMsg.errorAt (#2 e) "Field name not constant in pattern"; + "") + in + (x, patternOut e') + end) xes, flex), #2 e) + | EAnnot (e', t) => + (PAnnot (patternOut e', t), #2 e) + | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern."; + (PVar "_", #2 e)) + +%% +%header (functor UrwebLrValsFn(structure Token : TOKEN)) + +%term + EOF + | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char + | SYMBOL of string | CSYMBOL of string + | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE + | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR + | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT + | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI + | DATATYPE | OF + | TYPE | NAME + | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG + | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET + | LET | IN + | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | SQL | SELECT1 + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW + | COOKIE | STYLE | TASK | POLICY + | CASE | IF | THEN | ELSE | ANDALSO | ORELSE + + | XML_BEGIN of string | XML_END | XML_BEGIN_END of string + | NOTAGS of string + | BEGIN_TAG of string | END_TAG of string + + | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING + | UNION | INTERSECT | EXCEPT + | LIMIT | OFFSET | ALL + | TRUE | FALSE | CAND | OR | NOT + | COUNT | AVG | SUM | MIN | MAX | RANK | PARTITION | OVER + | ASC | DESC | RANDOM + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE + | CURRENT_TIMESTAMP + | NE | LT | LE | GT | GE + | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES + | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL + | CIF | CTHEN | CELSE + | FWDAPP | REVAPP | COMPOSE | ANDTHEN + | BACKTICK_PATH of string + +%nonterm + file of decl list + | decls of decl list + | decl of decl list + | vali of string * con option * exp + | valis of (string * con option * exp) list + | copt of con option + + | dargs of string list + | barOpt of unit + | dcons of (string * con option) list + | dtype of string * string list * (string * con option) list + | dtypes of (string * string list * (string * con option) list) list + | dcon of string * con option + + | pkopt of exp + | pk of exp + | commaOpt of unit + + | cst of exp + | csts of exp + | cstopt of exp + + | ckl of (string * kind option) list + + | pmode of prop_kind * exp + | pkind of prop_kind + | prule of exp + | pmodes of (prop_kind * exp) list + + | sgn of sgn + | sgntm of sgn + | sgi of sgn_item + | sgis of sgn_item list + + | str of str + + | kind of kind + | ktuple of kind list + | kcolon of explicitness + | kopt of kind option + + | path of string list * string + | cpath of string list * string + | spath of str + | mpath of string list + + | cexp of con + | cexpO of con option + | capps of con + | cterm of con + | ctuple of con list + | ctuplev of con list + | ident of con + | idents of con list + | rcon of (con * con) list + | rconn of (con * con) list + | rcone of (con * con) list + | cargs of con * kind -> con * kind + | cargl of con * kind -> con * kind + | cargl2 of con * kind -> con * kind + | carg of con * kind -> con * kind + | cargp of con * kind -> con * kind + + | eexp of exp + | eapps of exp + | eterm of exp + | etuple of exp list + | rexp of (con * exp) list * bool + | rpath of con + | xml of exp + | xmlOne of exp + | xmlOpt of exp + | tag of (string * exp) * exp option * exp option * exp option * exp + | tagHead of string * exp + | bind of pat * con option * exp + | edecl of edecl + | edecls of edecl list + + | earg of exp * con -> exp * con + | eargp of exp * con -> exp * con + | earga of exp * con -> exp * con + | eargs of exp * con -> exp * con + | eargl of exp * con -> exp * con + | eargl2 of bool * (exp * con -> exp * con) + + | branch of pat * exp + | branchs of (pat * exp) list + | pat of pat + | patS of pat + | pterm of pat + | rpat of (string * pat) list * bool + | ptuple of pat list + + | attrs of exp option * exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list + | attr of attr + | attrv of exp + + | query of exp + | query1 of exp + | dopt of exp + | tables of con list * exp + | fitem of con list * exp + | tname of con + | tnameW of con * con + | tnames of (con * con) * (con * con) list + | tnames' of (con * con) * (con * con) list + | table of con * exp + | table' of con * exp + | tident of con + | fident of con + | seli of select_item + | selis of select_item list + | select of select + | sqlexp of exp + | window of (exp * exp) option + | pbopt of exp + | wopt of exp + | groupi of group_item + | groupis of group_item list + | gopt of group_item list option + | hopt of exp + | obopt of exp + | obitem of exp * exp + | obexps of exp + | popt of unit + | diropt of exp + | lopt of exp + | ofopt of exp + | sqlint of exp + | sqlagg of string + | fname of exp + + | texp of exp + | fields of con list + | sqlexps of exp list + | fsets of (con * exp) list + | enterDml of unit + | leaveDml of unit + + | ffi_mode of ffi_mode + | ffi_modes of ffi_mode list + + +%verbose (* print summary of errors *) +%pos int (* positions *) +%start file +%pure +%eop EOF +%noshift EOF + +%name Urweb + +%right KARROW +%nonassoc DKARROW +%right SEMI +%nonassoc LARROW +%nonassoc IF THEN ELSE +%nonassoc DARROW +%left ANDALSO +%left ORELSE +%nonassoc COLON +%nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD +%left UNION INTERSECT EXCEPT ALL +%right COMMA +%right JOIN INNER CROSS OUTER LEFT RIGHT FULL +%right OR +%right CAND +%nonassoc EQ NE LT LE GT GE IS LIKE +%right ARROW + +%left REVAPP +%right FWDAPP +%left BACKTICK_PATH +%right COMPOSE ANDTHEN + +%right CARET PLUSPLUS +%left MINUSMINUS MINUSMINUSMINUS +%left PLUS MINUS +%left STAR DIVIDE MOD +%left NOT +%nonassoc TWIDDLE +%nonassoc DOLLAR +%left DOT +%nonassoc LBRACE RBRACE + +%% + +file : decls (decls) + | SIG sgis ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))), + s (SIGleft, sgisright))]) + +decls : ([]) + | decl decls (decl @ decls) + +decl : CON SYMBOL cargl2 kopt EQ cexp (let + val loc = s (CONleft, cexpright) + + val k = Option.getOpt (kopt, (KWild, loc)) + val (c, k) = cargl2 (cexp, k) + in + [(DCon (SYMBOL, SOME k, c), loc)] + end) + | LTYPE SYMBOL cargl2 EQ cexp (let + val loc = s (LTYPEleft, cexpright) + + val k = (KWild, loc) + val (c, k) = cargl2 (cexp, k) + in + [(DCon (SYMBOL, SOME k, c), loc)] + end) + | DATATYPE dtypes ([(DDatatype dtypes, s (DATATYPEleft, dtypesright))]) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))] + | _ => raise Fail "Arguments specified for imported datatype") + | VAL pat eargl2 copt EQ eexp (let + fun justVar (p : pat) = + case #1 p of + PVar x => SOME x + | PAnnot (p', _) => justVar p' + | _ => NONE + + val loc = s (VALleft, eexpright) + in + case justVar pat of + SOME x => + let + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + val (e, t) = #2 eargl2 (eexp, t) + val pat = + case #1 t of + CWild _ => pat + | _ => (PAnnot (pat, t), loc) + in + [(DVal (pat, e), loc)] + end + | NONE => + let + val pat = + case copt of + SOME t => (PAnnot (pat, t), loc) + | _ => pat + in + (if #1 eargl2 then + ErrorMsg.errorAt loc "Additional arguments not allowed after pattern" + else + ()); + [(DVal (pat, eexp), loc)] + end + end) + | VAL REC valis ([(DValRec valis, s (VALleft, valisright))]) + | FUN valis ([(DValRec valis, s (FUNleft, valisright))]) + + | SIGNATURE CSYMBOL EQ sgn ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))]) + | STRUCTURE CSYMBOL EQ str ([(DStr (CSYMBOL, NONE, NONE, str, false), s (STRUCTUREleft, strright))]) + | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str, false), s (STRUCTUREleft, strright))]) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str + ([(DStr (CSYMBOL1, NONE, NONE, + (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright)), false), + s (FUNCTORleft, strright))]) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str + ([(DStr (CSYMBOL1, NONE, NONE, + (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)), false), + s (FUNCTORleft, strright))]) + | OPEN mpath (case mpath of + [] => raise Fail "Impossible mpath parse [1]" + | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))]) + | OPEN mpath LPAREN str RPAREN (let + val loc = s (OPENleft, RPARENright) + + val m = case mpath of + [] => raise Fail "Impossible mpath parse [4]" + | m :: ms => + foldl (fn (m, str) => (StrProj (str, m), loc)) + (StrVar m, loc) ms + in + [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc), false), loc), + (DOpen ("anon", []), loc)] + end) + | OPEN CONSTRAINTS mpath (case mpath of + [] => raise Fail "Impossible mpath parse [3]" + | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))]) + | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))]) + | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) + | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), + s (TABLEleft, cstoptright))]) + | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) + | VIEW SYMBOL EQ query ([(DView (SYMBOL, query), + s (VIEWleft, queryright))]) + | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), + s (VIEWleft, RBRACEright))]) + | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) + | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) + | TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))]) + | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))]) + | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))]) + +dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons) + +dtypes : dtype ([dtype]) + | dtype AND dtypes (dtype :: dtypes) + +kopt : (NONE) + | DCOLON kind (SOME kind) + | DCOLONWILD (SOME (KWild, s (DCOLONWILDleft, DCOLONWILDright))) + +dargs : ([]) + | SYMBOL dargs (SYMBOL :: dargs) + +barOpt : () + | BAR () + +dcons : dcon ([dcon]) + | dcon BAR dcons (dcon :: dcons) + +dcon : CSYMBOL (CSYMBOL, NONE) + | CSYMBOL OF cexp (CSYMBOL, SOME cexp) + +vali : SYMBOL eargl2 copt EQ eexp (let + val loc = s (SYMBOLleft, eexpright) + val t = Option.getOpt (copt, (CWild (KType, loc), loc)) + + val (e, t) = #2 eargl2 (eexp, t) + in + (SYMBOL, SOME t, e) + end) + +copt : (NONE) + | COLON cexp (SOME cexp) + +cstopt : (EVar (["Basis"], "no_constraint", Infer), dummy) + | csts (csts) + +csts : CCONSTRAINT tname cst (let + val loc = s (CCONSTRAINTleft, cstright) + + val e = (EVar (["Basis"], "one_constraint", Infer), loc) + val e = (ECApp (e, tname), loc) + in + (EApp (e, cst), loc) + end) + | csts COMMA csts (let + val loc = s (csts1left, csts2right) + + val e = (EVar (["Basis"], "join_constraints", Infer), loc) + val e = (EApp (e, csts1), loc) + in + (EApp (e, csts2), loc) + end) + | LBRACE LBRACE eexp RBRACE RBRACE (eexp) + +cst : UNIQUE tnames (let + val loc = s (UNIQUEleft, tnamesright) + + val e = (EVar (["Basis"], "unique", Infer), loc) + val e = (ECApp (e, #1 (#1 tnames)), loc) + val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) + in + e + end) + + | CHECK sqlexp (let + val loc = s (CHECKleft, sqlexpright) + in + (EApp ((EVar (["Basis"], "check", Infer), loc), + sqlexp), loc) + end) + + | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes + (let + val loc = s (FOREIGNleft, pmodesright) + + val mat = ListPair.foldrEq + (fn ((nm1, _), (nm2, _), mat) => + let + val e = (EVar (["Basis"], "mat_cons", Infer), loc) + val e = (ECApp (e, nm1), loc) + val e = (ECApp (e, nm2), loc) + in + (EApp (e, mat), loc) + end) + (EVar (["Basis"], "mat_nil", Infer), loc) + (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames') + handle ListPair.UnequalLengths => + (ErrorMsg.errorAt loc ("Unequal foreign key list lengths (" + ^ Int.toString (1 + length (#2 tnames)) + ^ " vs. " + ^ Int.toString (1 + length (#2 tnames')) + ^ ")"); + (EVar (["Basis"], "mat_nil", Infer), loc)) + + fun findMode mode = + let + fun findMode' pmodes = + case pmodes of + [] => (EVar (["Basis"], "no_action", Infer), loc) + | (mode', rule) :: pmodes' => + if mode' = mode then + (if List.exists (fn (mode', _) => mode' = mode) + pmodes' then + ErrorMsg.errorAt loc "Duplicate propagation rule" + else + (); + rule) + else + findMode' pmodes' + in + findMode' pmodes + end + + val e = (EVar (["Basis"], "foreign_key", Infer), loc) + val e = (EApp (e, mat), loc) + val e = (EApp (e, texp), loc) + in + (EApp (e, (ERecord ([((CName "OnDelete", loc), + findMode Delete), + ((CName "OnUpdate", loc), + findMode Update)], false), loc)), loc) + end) + + | LBRACE eexp RBRACE (eexp) + +tnameW : tname (let + val loc = s (tnameleft, tnameright) + in + (tname, (CWild (KType, loc), loc)) + end) + +tnames : tnameW (tnameW, []) + | LPAREN tnames' RPAREN (tnames') + +tnames': tnameW (tnameW, []) + | tnameW COMMA tnames' (#1 tnames', tnameW :: #2 tnames') + +pmode : ON pkind prule (pkind, prule) + +pkind : DELETE (Delete) + | UPDATE (Update) + +prule : NO ACTION (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright)) + | RESTRICT (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright)) + | CASCADE (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright)) + | SET NULL (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright)) + +pmodes : ([]) + | pmode pmodes (pmode :: pmodes) + +commaOpt: () + | COMMA () + +pk : LBRACE LBRACE eexp RBRACE RBRACE (eexp) + | tnames (let + val loc = s (tnamesleft, tnamesright) + + val e = (EVar (["Basis"], "primary_key", TypesOnly), loc) + val e = (ECApp (e, #1 (#1 tnames)), loc) + val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc) + val e = (EDisjointApp e, loc) + val e = (EDisjointApp e, loc) + + val witness = map (fn (c, _) => + (c, (EWild, loc))) + (#1 tnames :: #2 tnames) + val witness = (ERecord (witness, false), loc) + in + (EApp (e, witness), loc) + end) + +pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy) + | PRIMARY KEY pk (pk) + +valis : vali ([vali]) + | vali AND valis (vali :: valis) + +sgn : sgntm (sgntm) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right)) + +sgntm : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright)) + | mpath (case mpath of + [] => raise Fail "Impossible mpath parse [2]" + | [x] => SgnVar x + | m :: ms => SgnProj (m, + List.take (ms, length ms - 1), + List.nth (ms, length ms - 1)), + s (mpathleft, mpathright)) + | sgntm WHERE CON path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright)) + | sgntm WHERE LTYPE path EQ cexp (SgnWhere (sgntm, #1 path, #2 path, cexp), s (sgntmleft, cexpright)) + | LPAREN sgn RPAREN (sgn) + +cexpO : (NONE) + | EQ cexp (SOME cexp) + +sgi : LTYPE SYMBOL ((SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))), + s (LTYPEleft, SYMBOLright))) + | CON SYMBOL cargl2 kopt cexpO (let + val loc = s (CONleft, cexpOright) + + val k = Option.getOpt (kopt, (KWild, loc)) + in + case cexpO of + NONE => (SgiConAbs (SYMBOL, k), loc) + | SOME cexp => + let + val (c, k) = cargl2 (cexp, k) + in + (SgiCon (SYMBOL, SOME k, c), loc) + end + end) + | LTYPE SYMBOL cargl2 cexpO (let + val loc = s (LTYPEleft, cexpOright) + + val k = (KWild, loc) + in + case cexpO of + NONE => (SgiConAbs (SYMBOL, k), loc) + | SOME cexp => + let + val (c, k) = cargl2 (cexp, k) + in + (SgiCon (SYMBOL, SOME k, c), loc) + end + end) + | DATATYPE dtypes ((SgiDatatype dtypes, s (DATATYPEleft, dtypesright))) + | DATATYPE SYMBOL dargs EQ DATATYPE CSYMBOL DOT path + (case dargs of + [] => (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright)) + | _ => raise Fail "Arguments specified for imported datatype") + | VAL SYMBOL COLON cexp ((SgiVal (SYMBOL, cexp), s (VALleft, cexpright))) + + | STRUCTURE CSYMBOL COLON sgn ((SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))) + | SIGNATURE CSYMBOL EQ sgn ((SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))) + | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn + ((SgiStr (CSYMBOL1, + (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))), + s (FUNCTORleft, sgn2right))) + | INCLUDE sgn ((SgiInclude sgn, s (INCLUDEleft, sgnright))) + | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))) + | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let + val loc = s (TABLEleft, ctermright) + in + (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc) + end) + | SEQUENCE SYMBOL (let + val loc = s (SEQUENCEleft, SYMBOLright) + val t = (CVar (["Basis"], "sql_sequence"), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + | VIEW SYMBOL COLON cexp (let + val loc = s (VIEWleft, cexpright) + val t = (CVar (["Basis"], "sql_view"), loc) + val t = (CApp (t, entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + | CLASS SYMBOL (let + val loc = s (CLASSleft, SYMBOLright) + val k = (KArrow ((KType, loc), (KType, loc)), loc) + in + (SgiClassAbs (SYMBOL, k), loc) + end) + | CLASS SYMBOL DCOLON kind (let + val loc = s (CLASSleft, kindright) + in + (SgiClassAbs (SYMBOL, kind), loc) + end) + | CLASS SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, (KWild, loc), cexp), loc) + end) + | CLASS SYMBOL DCOLON kind EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, kind, cexp), loc) + end) + | CLASS SYMBOL SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + val k = (KWild, loc) + val c = (CAbs (SYMBOL2, SOME k, cexp), loc) + in + (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright)) + end) + | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let + val loc = s (CLASSleft, cexpright) + val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) + in + (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright)) + end) + | COOKIE SYMBOL COLON cexp (let + val loc = s (COOKIEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "http_cookie"), loc), + entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + | STYLE SYMBOL (let + val loc = s (STYLEleft, SYMBOLright) + val t = (CVar (["Basis"], "css_class"), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + +sgis : ([]) + | sgi sgis (sgi :: sgis) + +str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright)) + | spath (spath) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str + (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright)) + | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str + (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright)) + | spath LPAREN str RPAREN (StrApp (spath, str), s (spathleft, RPARENright)) + +spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright)) + +kind : TYPE (KType, s (TYPEleft, TYPEright)) + | NAME (KName, s (NAMEleft, NAMEright)) + | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) + | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) + | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) + | KUNIT (KUnit, s (KUNITleft, KUNITright)) + | UNDERUNDER (KWild, s (UNDERUNDERleft, UNDERUNDERright)) + | LPAREN ktuple RPAREN (KTuple ktuple, s (LPARENleft, RPARENright)) + | CSYMBOL (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | CSYMBOL KARROW kind (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright)) + +ktuple : kind STAR kind ([kind1, kind2]) + | kind STAR ktuple (kind :: ktuple) + +capps : cterm (cterm) + | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) + +cexp : capps (capps) + | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) + | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) + | CSYMBOL KARROW cexp (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) + + | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) + + | FN cargs DARROW cexp (#1 (cargs (cexp, (KWild, s (FNleft, cexpright))))) + | LBRACK cexp TWIDDLE cexp RBRACK DARROW cexp (TDisjoint (cexp1, cexp2, cexp3), s (LBRACKleft, cexp3right)) + | CSYMBOL DKARROW cexp (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright)) + + | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright)) + + | UNDER DCOLON kind (CWild kind, s (UNDERleft, UNDERright)) + | ctuple (let + val loc = s (ctupleleft, ctupleright) + in + (TRecord (CRecord (ListUtil.mapi (fn (i, c) => + ((CName (Int.toString (i + 1)), loc), + c)) ctuple), + loc), loc) + end) + +kcolon : DCOLON (Explicit) + | TCOLON (Implicit) + +cargs : carg (carg) + | cargl (cargl) + +cargl : cargp cargp (cargp1 o cargp2) + | cargp cargl (cargp o cargl) + +cargl2 : (fn x => x) + | cargp cargl2 (cargp o cargl2) + +carg : SYMBOL DCOLON kind (fn (c, k) => + let + val loc = s (SYMBOLleft, kindright) + in + ((CAbs (SYMBOL, SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + | UNDER DCOLON kind (fn (c, k) => + let + val loc = s (UNDERleft, kindright) + in + ((CAbs ("_", SOME kind, c), loc), + (KArrow (kind, k), loc)) + end) + | SYMBOL DCOLONWILD (fn (c, k) => + let + val loc = s (SYMBOLleft, DCOLONWILDright) + val kind = (KWild, loc) + in + ((CAbs (SYMBOL, NONE, c), loc), + (KArrow (kind, k), loc)) + end) + | UNDER DCOLONWILD (fn (c, k) => + let + val loc = s (UNDERleft, DCOLONWILDright) + val kind = (KWild, loc) + in + ((CAbs ("_", NONE, c), loc), + (KArrow (kind, k), loc)) + end) + | cargp (cargp) + +cargp : SYMBOL (fn (c, k) => + let + val loc = s (SYMBOLleft, SYMBOLright) + in + ((CAbs (SYMBOL, NONE, c), loc), + (KArrow ((KWild, loc), k), loc)) + end) + | UNDER (fn (c, k) => + let + val loc = s (UNDERleft, UNDERright) + in + ((CAbs ("_", NONE, c), loc), + (KArrow ((KWild, loc), k), loc)) + end) + | LPAREN SYMBOL kopt ckl RPAREN (fn (c, k) => + let + val loc = s (LPARENleft, RPARENright) + val ckl = (SYMBOL, kopt) :: ckl + val ckl = map (fn (x, ko) => (x, case ko of + NONE => (KWild, loc) + | SOME k => k)) ckl + in + case ckl of + [(x, k')] => ((CAbs (SYMBOL, SOME k', c), loc), + (KArrow (k', k), loc)) + | _ => + let + val k' = (KTuple (map #2 ckl), loc) + + val c = foldr (fn ((x, k), c) => + (CAbs (x, SOME k, c), loc)) c ckl + val v = (CVar ([], "$x"), loc) + val c = ListUtil.foldli (fn (i, _, c) => + (CApp (c, (CProj (v, i + 1), loc)), + loc)) c ckl + in + ((CAbs ("$x", SOME k', c), loc), + (KArrow (k', k), loc)) + end + end) + +ckl : ([]) + | COMMA SYMBOL kopt ckl ((SYMBOL, kopt) :: ckl) + +path : SYMBOL ([], SYMBOL) + | CSYMBOL DOT path (let val (ms, x) = path in (CSYMBOL :: ms, x) end) + +cpath : CSYMBOL ([], CSYMBOL) + | CSYMBOL DOT cpath (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end) + +mpath : CSYMBOL ([CSYMBOL]) + | CSYMBOL DOT mpath (CSYMBOL :: mpath) + +cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) + | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) + | LBRACK rconn RBRACK (CRecord rconn, s (LBRACKleft, RBRACKright)) + | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), + s (LBRACEleft, RBRACEright)) + | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) + | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) + | HASH INT (CName (Int64.toString INT), s (HASHleft, INTright)) + + | path (CVar path, s (pathleft, pathright)) + | path DOT INT (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT), + s (pathleft, INTright)) + | UNDER (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright)) + | MAP (CMap, s (MAPleft, MAPright)) + | UNIT (CUnit, s (UNITleft, UNITright)) + | LPAREN ctuplev RPAREN (CTuple ctuplev, s (LPARENleft, RPARENright)) + +ctuplev: cexp COMMA cexp ([cexp1, cexp2]) + | cexp COMMA ctuplev (cexp :: ctuplev) + +ctuple : capps STAR capps ([capps1, capps2]) + | capps STAR ctuple (capps :: ctuple) + +rcon : ([]) + | rpath EQ cexp ([(rpath, cexp)]) + | rpath EQ cexp COMMA rcon ((rpath, cexp) :: rcon) + +rconn : rpath ([(rpath, (CUnit, s (rpathleft, rpathright)))]) + | rpath COMMA rconn ((rpath, (CUnit, s (rpathleft, rpathright))) :: rconn) + +rcone : ([]) + | rpath COLON cexp ([(rpath, cexp)]) + | rpath COLON cexp COMMA rcone ((rpath, cexp) :: rcone) + +ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | INT (CName (Int64.toString INT), s (INTleft, INTright)) + | SYMBOL (CVar ([], SYMBOL), s (SYMBOLleft, SYMBOLright)) + +eapps : eterm (eterm) + | eapps eterm (EApp (eapps, eterm), s (eappsleft, etermright)) + | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) + | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) + +eexp : eapps (case #1 eapps of + EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String (_, s)), loc)) => parseClass s loc + | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String (_, s)), loc)) => parseStyle s loc + | _ => eapps) + | FN eargs DARROW eexp (let + val loc = s (FNleft, eexpright) + in + #1 (eargs (eexp, (CWild (KType, loc), loc))) + end) + | CSYMBOL DKARROW eexp (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright)) + | eexp COLON cexp (EAnnot (eexp, cexp), s (eexpleft, cexpright)) + | eexp MINUSMINUS cexp (ECut (eexp, cexp), s (eexpleft, cexpright)) + | eexp MINUSMINUSMINUS cexp (ECutMulti (eexp, cexp), s (eexpleft, cexpright)) + | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright)) + | IF eexp THEN eexp ELSE eexp (let + val loc = s (IFleft, eexp3right) + in + (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), + ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) + end) + | bind SEMI eexp (let + val loc = s (bindleft, eexpright) + val (p, to, e1) = bind + val e = (EVar (["Basis"], "bind", Infer), loc) + val e = (EApp (e, e1), loc) + + val f = case #1 p of + PVar v => (EAbs (v, to, eexp), loc) + | _ => (EAbs ("$x", to, + (ECase ((EVar ([], "$x", Infer), loc), + [(p, eexp)]), loc)), loc) + in + (EApp (e, f), loc) + end) + | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right))) + | MINUS eterm (native_unop ("neg", eterm, s (MINUSleft, etermright))) + | eexp PLUS eexp (native_op ("plus", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp MINUS eexp (native_op ("minus", eexp1, eexp2, s (eexp1left, eexp2right))) + | eapps STAR eexp (native_op ("times", eapps, eexp, s (eappsleft, eexpright))) + | eexp DIVIDE eexp (native_op ("divide", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp MOD eexp (native_op ("mod", eexp1, eexp2, s (eexp1left, eexp2right))) + + | eexp LT eexp (native_op ("lt", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp LE eexp (native_op ("le", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right))) + + | eexp FWDAPP eexp (EApp (eexp1, eexp2), s (eexp1left, eexp2right)) + | eexp REVAPP eexp (EApp (eexp2, eexp1), s (eexp1left, eexp2right)) + | eexp COMPOSE eexp (top_binop ("compose", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp ANDTHEN eexp (top_binop ("compose", eexp2, eexp1, s (eexp1left, eexp2right))) + | eexp BACKTICK_PATH eexp (let + val path = String.tokens (fn ch => ch = #".") BACKTICK_PATH + val pathModules = List.take (path, (length path -1)) + val pathOp = List.last path + + val e = (EVar (pathModules, pathOp, Infer) + , s (BACKTICK_PATHleft, BACKTICK_PATHright)) + val e = (EApp (e, eexp1), s (eexp1left, BACKTICK_PATHright)) + in + (EApp (e, eexp2), s (eexp1left, eexp2right)) + end) + + | eexp ANDALSO eexp (let + val loc = s (eexp1left, eexp2right) + in + (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), + eexp2), + ((PCon (["Basis"], "False", NONE), loc), + (EVar (["Basis"], "False", Infer), loc))]), loc) + end) + | eexp ORELSE eexp (let + val loc = s (eexp1left, eexp2right) + in + (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), + (EVar (["Basis"], "True", Infer), loc)), + ((PCon (["Basis"], "False", NONE), loc), + eexp2)]), loc) + end) + + | eexp PLUSPLUS eexp (EConcat (eexp1, eexp2), s (eexp1left, eexp2right)) + + | eexp CARET eexp (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right))) + + | eapps DCOLON eexp (let + val loc = s (eappsleft, eexpright) + in + (EApp ((EVar (["Basis"], "Cons", Infer), loc), + (ERecord ([((CName "1", loc), + eapps), + ((CName "2", loc), + eexp)], false), loc)), loc) + end) + +bind : eapps LARROW eapps (patternOut eapps1, NONE, eapps2) + | eapps (let + val loc = s (eappsleft, eappsright) + in + ((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps) + end) + +eargs : earg (earg) + | eargl (eargl) + +eargl : eargp eargp (eargp1 o eargp2) + | eargp eargl (eargp o eargl) + +eargl2 : (false, fn x => x) + | eargp eargl2 (true, eargp o #2 eargl2) + +earg : patS (fn (e, t) => + let + val loc = s (patSleft, patSright) + val pt = patType loc patS + + val e' = case #1 patS of + PVar x => (EAbs (x, NONE, e), loc) + | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) + | _ => (EAbs ("$x", SOME pt, + (ECase ((EVar ([], "$x", DontInfer), + loc), + [(patS, e)]), loc)), loc) + in + (e', (TFun (pt, t), loc)) + end) + | earga (earga) + +eargp : pterm (fn (e, t) => + let + val loc = s (ptermleft, ptermright) + val pt = patType loc pterm + + val e' = case #1 pterm of + PVar x => (EAbs (x, NONE, e), loc) + | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) + | _ => (EAbs ("$x", SOME pt, + (ECase ((EVar ([], "$x", DontInfer), + loc), + [(pterm, e)]), loc)), loc) + in + (e', (TFun (pt, t), loc)) + end) + | earga (earga) + +earga : LBRACK SYMBOL RBRACK (fn (e, t) => + let + val loc = s (LBRACKleft, RBRACKright) + val kind = (KWild, loc) + in + ((ECAbs (Implicit, SYMBOL, kind, e), loc), + (TCFun (Implicit, SYMBOL, kind, t), loc)) + end) + | LBRACK SYMBOL DCOLONWILD RBRACK (fn (e, t) => + let + val loc = s (LBRACKleft, RBRACKright) + val kind = (KWild, loc) + in + ((ECAbs (Explicit, SYMBOL, kind, e), loc), + (TCFun (Explicit, SYMBOL, kind, t), loc)) + end) + | LBRACK SYMBOL kcolon kind RBRACK(fn (e, t) => + let + val loc = s (LBRACKleft, RBRACKright) + in + ((ECAbs (kcolon, SYMBOL, kind, e), loc), + (TCFun (kcolon, SYMBOL, kind, t), loc)) + end) + | LBRACK SYMBOL TCOLONWILD RBRACK (fn (e, t) => + let + val loc = s (LBRACKleft, RBRACKright) + val kind = (KWild, loc) + in + ((ECAbs (Implicit, SYMBOL, kind, e), loc), + (TCFun (Implicit, SYMBOL, kind, t), loc)) + end) + | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) => + let + val loc = s (LBRACKleft, RBRACKright) + in + ((EDisjoint (cexp1, cexp2, e), loc), + (TDisjoint (cexp1, cexp2, t), loc)) + end) + | LBRACK CSYMBOL RBRACK (fn (e, t) => + let + val loc = s (CSYMBOLleft, CSYMBOLright) + in + ((EKAbs (CSYMBOL, e), loc), + (TKFun (CSYMBOL, t), loc)) + end) + +eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) + | LPAREN etuple RPAREN (let + val loc = s (LPARENleft, RPARENright) + in + (ERecord (ListUtil.mapi (fn (i, e) => + ((CName (Int.toString (i + 1)), loc), + e)) etuple, false), loc) + end) + + | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) + | cpath (EVar (#1 cpath, #2 cpath, Infer), s (cpathleft, cpathright)) + | AT path (EVar (#1 path, #2 path, TypesOnly), s (ATleft, pathright)) + | AT AT path (EVar (#1 path, #2 path, DontInfer), s (AT1left, pathright)) + | AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright)) + | AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright)) + | LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright)) + | LBRACE RBRACE (ERecord ([], false), s (LBRACEleft, RBRACEright)) + | UNIT (ERecord ([], false), s (UNITleft, UNITright)) + + | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) + | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright)) + + | path DOT idents (let + val loc = s (pathleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents + end) + | LPAREN eexp RPAREN DOT idents (let + val loc = s (LPARENleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + eexp idents + end) + | AT path DOT idents (let + val loc = s (ATleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + (EVar (#1 path, #2 path, TypesOnly), s (pathleft, pathright)) idents + end) + | AT AT path DOT idents (let + val loc = s (AT1left, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents + end) + + | XML_BEGIN xml XML_END (let + val loc = s (XML_BEGINleft, XML_ENDright) + in + if XML_BEGIN = "xml" then + () + else + ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; + xml + end) + | XML_BEGIN XML_END (let + val loc = s (XML_BEGINleft, XML_ENDright) + in + if XML_BEGIN = "xml" then + () + else + ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; + (EApp ((EVar (["Basis"], "cdata", Infer), loc), + (EPrim (Prim.String (Prim.Html, "")), loc)), + loc) + end) + | XML_BEGIN_END (let + val loc = s (XML_BEGIN_ENDleft, XML_BEGIN_ENDright) + in + if XML_BEGIN_END = "xml" then + () + else + ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; + (EApp ((EVar (["Basis"], "cdata", Infer), loc), + (EPrim (Prim.String (Prim.Html, "")), loc)), + loc) + end) + + | LPAREN query RPAREN (query) + | LPAREN CWHERE sqlexp RPAREN (sqlexp) + | LPAREN SQL sqlexp RPAREN (sqlexp) + | LPAREN FROM tables RPAREN (#2 tables) + | LPAREN SELECT1 query1 RPAREN (query1) + + | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN + (let + val loc = s (LPAREN1left, RPAREN3right) + + val e = (EVar (["Basis"], "insert", Infer), loc) + val e = (EApp (e, texp), loc) + in + if length fields <> length sqlexps then + ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification (" + ^ Int.toString (length fields) + ^ " vs. " ^ Int.toString (length sqlexps) ^ ")") + else + (); + (EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc) + end) + | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN + (let + val loc = s (LPARENleft, RPARENright) + + val e = (EVar (["Basis"], "update", Infer), loc) + val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc) + val e = (EApp (e, (ERecord (fsets, false), loc)), loc) + val e = (EApp (e, texp), loc) + in + (EApp (e, sqlexp), loc) + end) + | LPAREN enterDml DELETE FROM texp CWHERE sqlexp leaveDml RPAREN + (let + val loc = s (LPARENleft, RPARENright) + + val e = (EVar (["Basis"], "delete", Infer), loc) + val e = (EApp (e, texp), loc) + in + (EApp (e, sqlexp), loc) + end) + + | UNDER (EWild, s (UNDERleft, UNDERright)) + + | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright)) + | LET eexp WHERE edecls END (ELet (edecls, eexp), s (LETleft, ENDright)) + + | LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright)) + +edecls : ([]) + | edecl edecls (edecl :: edecls) + +edecl : VAL pat EQ eexp ((EDVal (pat, eexp), s (VALleft, eexpright))) + | VAL REC valis ((EDValRec valis, s (VALleft, valisright))) + | FUN valis ((EDValRec valis, s (FUNleft, valisright))) + +enterDml : (inDml := true) +leaveDml : (inDml := false) + +texp : SYMBOL (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)) + | LBRACE LBRACE eexp RBRACE RBRACE (eexp) + +fields : fident ([fident]) + | fident COMMA fields (fident :: fields) + +sqlexps: sqlexp ([sqlexp]) + | sqlexp COMMA sqlexps (sqlexp :: sqlexps) + +fsets : fident EQ sqlexp ([(fident, sqlexp)]) + | fident EQ sqlexp COMMA fsets ((fident, sqlexp) :: fsets) + +idents : ident ([ident]) + | ident DOT idents (ident :: idents) + +etuple : eexp COMMA eexp ([eexp1, eexp2]) + | eexp COMMA etuple (eexp :: etuple) + +branch : pat DARROW eexp (pat, eexp) + +branchs: ([]) + | BAR branch branchs (branch :: branchs) + +patS : pterm (pterm) + | pterm DCOLON patS (let + val loc = s (ptermleft, patSright) + in + (PCon (["Basis"], "Cons", SOME (PRecord ([("1", pterm), + ("2", patS)], false), loc)), + loc) + end) + | patS COLON cexp (PAnnot (patS, cexp), s (patSleft, cexpright)) + +pat : patS (patS) + | cpath pterm (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright)) + +pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright)) + | cpath (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright)) + | UNDER (PVar "_", s (UNDERleft, UNDERright)) + | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) + | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) + | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) + | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) + | LPAREN pat RPAREN (pat) + | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) + | UNIT (PRecord ([], false), s (UNITleft, UNITright)) + | LBRACE rpat RBRACE (PRecord rpat, s (LBRACEleft, RBRACEright)) + | LPAREN ptuple RPAREN (PRecord (ListUtil.mapi (fn (i, p) => (Int.toString (i + 1), p)) ptuple, + false), + s (LPARENleft, RPARENright)) + | LBRACK RBRACK (PCon (["Basis"], "Nil", NONE), s (LBRACKleft, RBRACKright)) + +rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) + | INT EQ pat ([(Int64.toString INT, pat)], false) + | DOTDOTDOT ([], true) + | CSYMBOL EQ pat COMMA rpat ((CSYMBOL, pat) :: #1 rpat, #2 rpat) + | INT EQ pat COMMA rpat ((Int64.toString INT, pat) :: #1 rpat, #2 rpat) + +ptuple : pat COMMA pat ([pat1, pat2]) + | pat COMMA ptuple (pat :: ptuple) + +rexp : DOTDOTDOT ([], true) + | rpath EQ eexp ([(rpath, eexp)], false) + | rpath EQ eexp COMMA rexp ((rpath, eexp) :: #1 rexp, #2 rexp) + +rpath : path (CVar path, s (pathleft, pathright)) + | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + +xml : xmlOne xml (let + val pos = s (xmlOneleft, xmlright) + in + (EApp ((EApp ( + (EVar (["Basis"], "join", Infer), pos), + xmlOne), pos), + xml), pos) + end) + | xmlOne (xmlOne) + +xmlOpt : xml (xml) + | (EApp ((EVar (["Basis"], "cdata", Infer), dummy), + (EPrim (Prim.String (Prim.Html, "")), dummy)), + dummy) + +xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)), + (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))), + s (NOTAGSleft, NOTAGSright)) + | tag DIVIDE GT (let + val pos = s (tagleft, GTright) + + val cdata = + if #1 (#1 tag) = "submit" orelse #1 (#1 tag) = "dyn" then + let + val e = (EVar (["Basis"], "cdata", DontInfer), pos) + val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) + in + (ECApp (e, (CRecord [], pos)), pos) + end + else + (EVar (["Basis"], "cdata", Infer), pos) + + val cdata = (EApp (cdata, + (EPrim (Prim.String (Prim.Html, "")), pos)), + pos) + in + (EApp (#5 tag, cdata), pos) + end) + + | tag GT xmlOpt END_TAG (let + fun tagOut s = + case s of + "tabl" => "table" + | _ => s + + val pos = s (tagleft, GTright) + val et = tagIn END_TAG + in + if #1 (#1 tag) = et then + if et = "form" then + let + val e = (EVar (["Basis"], "form", Infer), pos) + val e = (EApp (e, case #4 tag of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) + val e = (EApp (e, case #2 tag of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME (EPrim (Prim.String (_, s)), _) => (EApp ((EVar (["Basis"], "Some", Infer), pos), parseClass s pos), pos) + | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) + in + case #3 tag of + NONE => () + | SOME _ => ErrorMsg.errorAt pos "<form> does not support 'dynClass' attribute"; + (EApp (e, xmlOpt), pos) + end + else if et = "subform" orelse et = "subforms" then + (EApp (#2 (#1 tag), + xmlOpt), pos) + else if et = "entry" then + (EApp ((EVar (["Basis"], "entry", Infer), pos), + xmlOpt), pos) + else + (EApp (#5 tag, xmlOpt), pos) + else + (if ErrorMsg.anyErrors () then + () + else + ErrorMsg.errorAt pos ("Begin tag <" + ^ tagOut (#1 (#1 tag)) + ^ "> and end tag </" + ^ tagOut et + ^ "> don't match."); + (EWild, pos)) + end) + | LBRACE eexp RBRACE (eexp) + | LBRACE LBRACK eexp RBRACK RBRACE (let + val loc = s (LBRACEleft, RBRACEright) + val e = (EVar (["Top"], "txt", Infer), loc) + in + (EApp (e, eexp), loc) + end) + +tag : tagHead attrs (let + val pos = s (tagHeadleft, attrsright) + + val e = (EVar (["Basis"], "tag", Infer), pos) + val eo = case #1 attrs of + NONE => (EVar (["Basis"], "null", Infer), pos) + | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos + | SOME e => e + val e = (EApp (e, eo), pos) + val eo = case #2 attrs of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), + e), pos) + val e = (EApp (e, eo), pos) + val eo = case #3 attrs of + NONE => (EVar (["Basis"], "noStyle", Infer), pos) + | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos + | SOME e => e + val e = (EApp (e, eo), pos) + val eo = case #4 attrs of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), + e), pos) + val e = (EApp (e, eo), pos) + + val atts = case #6 attrs of + [] => #7 attrs + | data :: datas => + let + fun doOne (kind, name, value) = + let + val e = (EVar (["Basis"], "data_attr", Infer), pos) + val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos) + val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos) + in + (EApp (e, value), pos) + end + + val datas' = foldl (fn (nv, acc) => + let + val e = (EVar (["Basis"], "data_attrs", Infer), pos) + val e = (EApp (e, acc), pos) + in + (EApp (e, doOne nv), pos) + end) (doOne data) datas + in + ((CName "Data", pos), datas') :: #7 attrs + end + + val e = (EApp (e, (ERecord (atts, false), pos)), pos) + val e = (EApp (e, (EApp (#2 tagHead, + (ERecord ([], false), pos)), pos)), pos) + in + (tagHead, #1 attrs, #2 attrs, #5 attrs, e) + end) + +tagHead: BEGIN_TAG (let + val bt = tagIn BEGIN_TAG + val pos = s (BEGIN_TAGleft, BEGIN_TAGright) + in + (bt, + (EVar ([], bt, Infer), pos)) + end) + | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) + +attrs : (NONE, NONE, NONE, NONE, NONE, [], []) + | attr attrs (let + val loc = s (attrleft, attrsright) + in + case attr of + Class e => + (case #1 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; + (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs)) + | DynClass e => + (case #2 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; + (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs, #7 attrs)) + | Style e => + (case #3 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag"; + (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs, #7 attrs)) + | DynStyle e => + (case #4 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; + (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs, #7 attrs)) + | Data xe => + (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs, #7 attrs) + | Normal xe => + (#1 attrs, #2 attrs, #3 attrs, #4 attrs, (case #1 (#1 xe) of + CName "Id" => SOME (#2 xe) + | _ => #5 attrs), #6 attrs, xe :: #7 attrs) + end) + +attr : SYMBOL EQ attrv (case SYMBOL of + "class" => Class attrv + | "dynClass" => DynClass attrv + | "style" => Style attrv + | "dynStyle" => DynStyle attrv + | _ => + if String.isPrefix "data-" SYMBOL then + Data ("data", String.extract (SYMBOL, 5, NONE), attrv) + else if String.isPrefix "aria-" SYMBOL then + Data ("aria", String.extract (SYMBOL, 5, NONE), attrv) + else + let + val sym = makeAttr SYMBOL + in + Normal ((CName sym, s (SYMBOLleft, SYMBOLright)), + if (sym = "Href" orelse sym = "Src") + andalso (case #1 attrv of + EPrim _ => true + | _ => false) then + let + val loc = s (attrvleft, attrvright) + in + (EApp ((EVar (["Basis"], "bless", Infer), loc), + attrv), loc) + end + else if sym = "Nam" + andalso (case #1 attrv of + EPrim _ => true + | _ => false) then + let + val loc = s (attrvleft, attrvright) + in + (EApp ((EVar (["Basis"], "blessMeta", Infer), loc), + attrv), loc) + end + else + attrv) + end) + | SYMBOL (let + val loc = s (SYMBOLleft, SYMBOLright) + in + Normal ((CName (makeAttr SYMBOL), loc), + (EVar (["Basis"], "True", Infer), loc)) + end) + +attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) + | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) + | LBRACE eexp RBRACE (eexp) + +query : query1 obopt lopt ofopt (let + val loc = s (query1left, query1right) + + val re = (ERecord ([((CName "Rows", loc), + query1), + ((CName "OrderBy", loc), + obopt), + ((CName "Limit", loc), + lopt), + ((CName "Offset", loc), + ofopt)], false), loc) + in + (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc) + end) + +dopt : (EVar (["Basis"], "False", Infer), dummy) + | DISTINCT (EVar (["Basis"], "True", Infer), + s (DISTINCTleft, DISTINCTright)) + +query1 : SELECT dopt select FROM tables wopt gopt hopt + (let + val loc = s (SELECTleft, tablesright) + + val (empties, sel, exps) = + case select of + Star => ([], + map (fn nm => + (nm, (CTuple [(CWild (KRecord (KType, loc), loc), + loc), + (CRecord [], loc)], + loc))) (#1 tables), + []) + | Items sis => + let + val tabs = map (fn nm => (nm, Unknown)) (#1 tables) + val (_, tabs, exps) = foldl (amend_select loc) + (1, tabs, []) sis + val empties = List.mapPartial (fn (nm, c) => + case c of + Unknown => SOME nm + | Selective (CRecord [], _) => SOME nm + | _ => NONE) tabs + in + (empties, + map (fn (nm, c) => (nm, + case c of + Everything => + (CTuple [(CWild (KRecord (KType, loc), loc), loc), + (CRecord [], loc)], loc) + | _ => + let + val c = case c of + Selective c => c + | _ => (CRecord [], loc) + in + (CTuple [c, + (CWild (KRecord (KType, loc), loc), + loc)], loc) + end)) tabs, + exps) + end + + val exps = map (fn (c, e) => (c, (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc))) exps + + val sel = (CRecord sel, loc) + + val grp = case gopt of + NONE => (ECApp ((EVar (["Basis"], "sql_subset_all", + Infer), loc), + (CWild (KRecord (KRecord (KType, loc), loc), + loc), loc)), loc) + | SOME gis => + let + val tabs = map (fn nm => + (nm, (CRecord [], loc))) (#1 tables) + val tabs = foldl (amend_group loc) tabs gis + + val tabs = map (fn (nm, c) => + (nm, + (CTuple [c, + (CWild (KRecord (KType, loc), + loc), + loc)], loc))) tabs + in + (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc), + (CRecord tabs, loc)), loc) + end + + val e = (EVar (["Basis"], "sql_query1", Infer), loc) + val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties), + loc)), loc) + val re = (ERecord ([((CName "Distinct", loc), + dopt), + ((CName "From", loc), + #2 tables), + ((CName "Where", loc), + wopt), + ((CName "GroupBy", loc), + grp), + ((CName "Having", loc), + hopt), + ((CName "SelectFields", loc), + (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc), + sel), loc)), + ((CName "SelectExps", loc), + (ERecord (exps, false), loc))], false), loc) + + val e = (EApp (e, re), loc) + in + e + end) + | query1 UNION query1 (sql_relop ("union", false, query11, query12, s (query11left, query12right))) + | query1 INTERSECT query1 (sql_relop ("intersect", false, query11, query12, s (query11left, query12right))) + | query1 EXCEPT query1 (sql_relop ("except", false, query11, query12, s (query11left, query12right))) + | query1 UNION ALL query1 (sql_relop ("union", true, query11, query12, s (query11left, query12right))) + | query1 INTERSECT ALL query1 (sql_relop ("intersect", true, query11, query12, s (query11left, query12right))) + | query1 EXCEPT ALL query1 (sql_relop ("except", true, query11, query12, s (query11left, query12right))) + | LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) + +tables : fitem (fitem) + | fitem COMMA tables (let + val loc = s (fitemleft, tablesright) + + val e = (EVar (["Basis"], "sql_from_comma", Infer), loc) + val e = (EApp (e, #2 fitem), loc) + in + (#1 fitem @ #1 tables, + (EApp (e, #2 tables), loc)) + end) + +fitem : table' ([#1 table'], #2 table') + | LBRACE LBRACE eexp RBRACE RBRACE (tnamesOf eexp, eexp) + | fitem JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem INNER JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem CROSS JOIN fitem (let + val loc = s (fitem1left, fitem2right) + + val e = (EVar (["Basis"], "sql_inner_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + val tru = sql_inject (EVar (["Basis"], "True", Infer), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, tru), loc)) + end) + | fitem LEFT JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_left_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem LEFT OUTER JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_left_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem RIGHT JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_right_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem RIGHT OUTER JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_right_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem FULL JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_full_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | fitem FULL OUTER JOIN fitem ON sqlexp (let + val loc = s (fitem1left, sqlexpright) + + val e = (EVar (["Basis"], "sql_full_join", Infer), loc) + val e = (EApp (e, #2 fitem1), loc) + val e = (EApp (e, #2 fitem2), loc) + in + (#1 fitem1 @ #1 fitem2, + (EApp (e, sqlexp), loc)) + end) + | LPAREN query RPAREN AS tname (let + val loc = s (LPARENleft, RPARENright) + + val e = (EVar (["Basis"], "sql_from_query", Infer), loc) + val e = (ECApp (e, tname), loc) + in + ([tname], (EApp (e, query), loc)) + end) + | LPAREN LBRACE LBRACE eexp RBRACE RBRACE RPAREN AS tname (let + val loc = s (LPARENleft, RPARENright) + + val e = (EVar (["Basis"], "sql_from_query", Infer), loc) + val e = (ECApp (e, tname), loc) + in + ([tname], (EApp (e, eexp), loc)) + end) + | LPAREN fitem RPAREN (fitem) + +tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +table : SYMBOL ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), + (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))) + | SYMBOL AS tname (tname, (EVar ([], SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))) + | LBRACE LBRACE eexp RBRACE RBRACE AS tname (tname, eexp) + +table' : table (let + val loc = s (tableleft, tableright) + val e = (EVar (["Basis"], "sql_from_table", Infer), loc) + val e = (ECApp (e, #1 table), loc) + in + (#1 table, (EApp (e, #2 table), loc)) + end) + +tident : SYMBOL (CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)) + | CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE LBRACE cexp RBRACE RBRACE (cexp) + +fident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | LBRACE cexp RBRACE (cexp) + +seli : tident DOT fident (Field (tident, fident)) + | sqlexp (Exp (NONE, sqlexp)) + | sqlexp AS fident (Exp (SOME fident, sqlexp)) + | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (Fields (tident, cexp)) + | tident DOT STAR (StarFields tident) + +selis : seli ([seli]) + | seli COMMA selis (seli :: selis) + +select : STAR (Star) + | selis (Items selis) + +sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", Infer), + s (TRUEleft, TRUEright))) + | FALSE (sql_inject (EVar (["Basis"], "False", Infer), + s (FALSEleft, FALSEright))) + + | INT (sql_inject (EPrim (Prim.Int INT), + s (INTleft, INTright))) + | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), + s (FLOATleft, FLOATright))) + | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)), + s (STRINGleft, STRINGright))) + | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", + s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) + + | tident DOT fident (let + val loc = s (tidentleft, fidentright) + val e = (EVar (["Basis"], "sql_field", Infer), loc) + val e = (ECApp (e, tident), loc) + in + (ECApp (e, fident), loc) + end) + | CSYMBOL (let + val loc = s (CSYMBOLleft, CSYMBOLright) + in + if !inDml then + let + val e = (EVar (["Basis"], "sql_field", Infer), loc) + val e = (ECApp (e, (CName "T", loc)), loc) + in + (ECApp (e, (CName CSYMBOL, loc)), loc) + end + else + let + val e = (EVar (["Basis"], "sql_exp", Infer), loc) + in + (ECApp (e, (CName CSYMBOL, loc)), loc) + end + end) + + | LBRACE eexp RBRACE (eexp) + + | sqlexp EQ sqlexp (sql_binary ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp NE sqlexp (sql_binary ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LT sqlexp (sql_binary ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp LE sqlexp (sql_binary ("le", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GT sqlexp (sql_binary ("gt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp GE sqlexp (sql_binary ("ge", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp PLUS sqlexp (sql_binary ("plus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp MINUS sqlexp (sql_binary ("minus", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp STAR sqlexp (sql_binary ("times", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp DIVIDE sqlexp (sql_binary ("div", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp MOD sqlexp (sql_binary ("mod", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp CAND sqlexp (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | sqlexp LIKE sqlexp (sql_binary ("like", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) + + | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + | MINUS sqlexp (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright))) + + | sqlexp IS NULL (let + val loc = s (sqlexpleft, NULLright) + in + (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc), + sqlexp), loc) + end) + + | CIF sqlexp CTHEN sqlexp CELSE sqlexp (let + val loc = s (CIFleft, sqlexp3right) + val e = (EVar (["Basis"], "sql_if_then_else", Infer), loc) + in + (EApp ((EApp ((EApp (e, sqlexp1), loc), sqlexp2), loc), sqlexp3), loc) + end) + + | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp, + s (LBRACEleft, RBRACEright))) + | LPAREN sqlexp RPAREN (sqlexp) + + | NULL (sql_inject ((EVar (["Basis"], "None", Infer), + s (NULLleft, NULLright)))) + + | COUNT LPAREN STAR RPAREN window(let + val loc = s (COUNTleft, windowright) + in + case window of + NONE => (EVar (["Basis"], "sql_count", Infer), loc) + | SOME _ => applyWindow loc (EVar (["Basis"], "sql_window_count", Infer), loc) window + end) + | COUNT LPAREN sqlexp RPAREN window(let + val loc = s (COUNTleft, RPARENright) + val e = (EVar (["Basis"], "sql_count_col", Infer), loc) + in + case window of + NONE => + let + val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc), + e), loc) + in + (EApp (e, sqlexp), loc) + end + | SOME _ => + let + val e = (EVar (["Basis"], "sql_count_col", Infer), loc) + val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc), + e), loc) + in + applyWindow loc (EApp (e, sqlexp), loc) window + end + end) + | sqlagg LPAREN sqlexp RPAREN window (let + val loc = s (sqlaggleft, RPARENright) + + val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc) + in + case window of + NONE => + let + val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc), + e), loc) + in + (EApp (e, sqlexp), loc) + end + | SOME _ => + let + val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc), + e), loc) + in + applyWindow loc (EApp (e, sqlexp), loc) window + end + end) + | RANK UNIT window (let + val loc = s (RANKleft, windowright) + in + applyWindow loc (EVar (["Basis"], "sql_rank", Infer), loc) window + end) + | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN + (let + val loc = s (COALESCEright, sqlexp2right) + val e = (EVar (["Basis"], "sql_coalesce", Infer), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) + end) + | fname LPAREN sqlexp RPAREN (let + val loc = s (fnameleft, RPARENright) + + val e = (EVar (["Basis"], "sql_ufunc", Infer), loc) + val e = (EApp (e, fname), loc) + in + (EApp (e, sqlexp), loc) + end) + | LPAREN query RPAREN (let + val loc = s (LPARENleft, RPARENright) + + val e = (EVar (["Basis"], "sql_subquery", Infer), loc) + in + (EApp (e, query), loc) + end) + +window : (NONE) + | OVER LPAREN pbopt obopt RPAREN (SOME (pbopt, obopt)) + +pbopt : ((EVar (["Basis"], "sql_no_partition", Infer), dummy)) + | PARTITION BY sqlexp (let + val loc = s (PARTITIONleft, sqlexpright) + + val e = (EVar (["Basis"], "sql_partition", Infer), loc) + in + (EApp (e, sqlexp), loc) + end) + +fname : SYMBOL (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright)) + | LBRACE eexp RBRACE (eexp) + +wopt : (sql_inject (EVar (["Basis"], "True", Infer), + dummy)) + | CWHERE sqlexp (sqlexp) + +groupi : tident DOT fident (GField (tident, fident)) + | tident DOT LBRACE LBRACE cexp RBRACE RBRACE (GFields (tident, cexp)) + +groupis: groupi ([groupi]) + | groupi COMMA groupis (groupi :: groupis) + +gopt : (NONE) + | GROUP BY groupis (SOME groupis) + +hopt : (sql_inject (EVar (["Basis"], "True", Infer), + dummy)) + | HAVING sqlexp (sqlexp) + +obopt : (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy), + (CWild (KRecord (KType, dummy), dummy), dummy)), + dummy) + | ORDER BY obexps (obexps) + | ORDER BY LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) + +obitem : sqlexp diropt (sqlexp, diropt) + +obexps : obitem (let + val loc = s (obitemleft, obitemright) + + val e' = (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), loc), + (CWild (KRecord (KType, loc), loc), loc)), + loc) + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc), + #1 obitem), loc) + val e = (EApp (e, #2 obitem), loc) + in + (EApp (e, e'), loc) + end) + | obitem COMMA obexps (let + val loc = s (obitemleft, obexpsright) + + val e = (EApp ((EVar (["Basis"], "sql_order_by_Cons", Infer), loc), + #1 obitem), loc) + val e = (EApp (e, #2 obitem), loc) + in + (EApp (e, obexps), loc) + end) + | RANDOM popt (EVar (["Basis"], "sql_order_by_random", Infer), s (RANDOMleft, poptright)) + +popt : () + | LPAREN RPAREN () + | UNIT () + +diropt : (EVar (["Basis"], "sql_asc", Infer), dummy) + | ASC (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright)) + | DESC (EVar (["Basis"], "sql_desc", Infer), s (DESCleft, DESCright)) + | LBRACE eexp RBRACE (eexp) + +lopt : (EVar (["Basis"], "sql_no_limit", Infer), dummy) + | LIMIT ALL (EVar (["Basis"], "sql_no_limit", Infer), dummy) + | LIMIT sqlint (let + val loc = s (LIMITleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_limit", Infer), loc), sqlint), loc) + end) + +ofopt : (EVar (["Basis"], "sql_no_offset", Infer), dummy) + | OFFSET sqlint (let + val loc = s (OFFSETleft, sqlintright) + in + (EApp ((EVar (["Basis"], "sql_offset", Infer), loc), sqlint), loc) + end) + +sqlint : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) + | LBRACE eexp RBRACE (eexp) + +sqlagg : AVG ("avg") + | SUM ("sum") + | MIN ("min") + | MAX ("max") + +ffi_mode : SYMBOL (case SYMBOL of + "effectful" => Effectful + | "benignEffectful" => BenignEffectful + | "clientOnly" => ClientOnly + | "serverOnly" => ServerOnly + | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful)) + | SYMBOL STRING (case SYMBOL of + "jsFunc" => JsFunc STRING + | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful)) + +ffi_modes : ([]) + | ffi_mode ffi_modes (ffi_mode :: ffi_modes) diff --git a/src/urweb.lex b/src/urweb.lex new file mode 100644 index 0000000..368b9f1 --- /dev/null +++ b/src/urweb.lex @@ -0,0 +1,579 @@ +(* -*- mode: sml-lex -*- *) + +(* Copyright (c) 2008-2009, 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. + *) + +(* Lexing info for Ur/Web programs *) + +type pos = int +type svalue = Tokens.svalue +type ('a,'b) token = ('a,'b) Tokens.token +type lexresult = (svalue,pos) Tokens.token + +val commentOut = ref (fn () => ()) + +local + val commentLevel = ref 0 + val commentPos = ref 0 +in + fun reset () = + (commentLevel := 0; + commentPos := 0) + + fun enterComment pos = + (if !commentLevel = 0 then + commentPos := pos + else + (); + commentLevel := !commentLevel + 1) + + fun exitComment () = + (ignore (commentLevel := !commentLevel - 1); + if !commentLevel = 0 then + !commentOut () + else + ()) + + fun eof () = + let + val pos = ErrorMsg.lastLineStart () + in + if !commentLevel > 0 then + ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" + else + (); + Tokens.EOF (pos, pos) + end +end + +val strEnder = ref #"\"" +val str = ref ([] : char list) +val strStart = ref 0 + +local + val initSig = ref false + val offset = ref 0 +in + +fun initialSig () = initSig := true + +fun pos yypos = yypos - !offset + +fun newline yypos = + if !initSig then + (initSig := false; + offset := yypos + 1) + else + ErrorMsg.newline (pos yypos) + +end + +val xmlTag = ref ([] : string list) +val xmlString = ref true +val braceLevels = ref ([] : ((unit -> unit) * int) list) + +fun pushLevel s = braceLevels := (s, 1) :: (!braceLevels) + +fun enterBrace () = + case !braceLevels of + (s, i) :: rest => braceLevels := (s, i+1) :: rest + | _ => () + +fun exitBrace () = + case !braceLevels of + (s, i) :: rest => + if i = 1 then + (braceLevels := rest; + s ()) + else + braceLevels := (s, i-1) :: rest + | _ => () + +fun initialize () = (reset (); + xmlTag := []; + xmlString := false) + + +structure StringMap = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +val entities = foldl (fn ((key, value), entities) => StringMap.insert (entities, key, value)) + StringMap.empty Entities.all + +fun unescape loc s = + let + fun process (s, acc) = + let + val (befor, after) = Substring.splitl (fn ch => ch <> #"&") s + in + if Substring.size after = 0 then + Substring.concat (rev (s :: acc)) + else + let + val after = Substring.slice (after, 1, NONE) + val (befor', after') = Substring.splitl (fn ch => ch <> #";") after + in + if Substring.size after' = 0 then + (ErrorMsg.errorAt' loc "Missing ';' after '&'"; + "") + else + let + val pre = befor + val code = befor' + val s = Substring.slice (after', 1, NONE) + + val special = + if Substring.size code > 0 andalso Substring.sub (code, 0) = #"#" + andalso CharVectorSlice.all Char.isDigit (Substring.slice (code, 1, NONE)) then + let + val code = Substring.string (Substring.slice (code, 1, NONE)) + in + Option.map Utf8.encode (Int.fromString code) + end + else + Option.map Utf8.encode (StringMap.find (entities, Substring.string code)) + in + case special of + NONE => (ErrorMsg.errorAt' loc ("Unsupported XML character entity " + ^ Substring.string code); + "") + | SOME sp => process (s, Substring.full sp :: pre :: acc) + end + end + end + in + process (Substring.full s, []) + end + +%% +%header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); +%full +%s COMMENT STRING CHAR XML XMLTAG; + +id = [a-z_][A-Za-z0-9_']*; +xmlid = [A-Za-z][A-Za-z0-9_-]*; +cid = [A-Z][A-Za-z0-9_']*; +ws = [\ \t\012\r]; +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> + \n => (newline yypos; + continue ()); +<XML> \n => (newline yypos; + Tokens.NOTAGS (yytext, yypos, yypos + size yytext)); + +<INITIAL> {ws}+ => (lex ()); + +<INITIAL> "(*" => (YYBEGIN COMMENT; + commentOut := (fn () => YYBEGIN INITIAL); + enterComment (pos yypos); + continue ()); +<XML> "(*" => (YYBEGIN COMMENT; + commentOut := (fn () => YYBEGIN XML); + enterComment (pos yypos); + continue ()); +<XMLTAG> "(*" => (YYBEGIN COMMENT; + commentOut := (fn () => YYBEGIN XMLTAG); + enterComment (pos yypos); + continue ()); +<INITIAL,XML,XMLTAG> + "*)" => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments"; + continue ()); + +<COMMENT> "(*" => (enterComment (pos yypos); + continue ()); +<COMMENT> "*)" => (exitComment (); + continue ()); + +<XML> "<!--" {xcom} "-->" => (continue ()); + +<STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); +<STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); +<STRING,CHAR> "\\n" => (str := #"\n" :: !str; continue()); +<STRING,CHAR> "\\r" => (str := #"\r" :: !str; continue()); +<STRING,CHAR> "\\\\" => (str := #"\\" :: !str; continue()); +<STRING,CHAR> "\\t" => (str := #"\t" :: !str; continue()); +<STRING,CHAR> "\n" => (newline yypos; + str := #"\n" :: !str; continue()); +<STRING,CHAR> "\\" {oint} => (case StringCvt.scanString (Int.scan StringCvt.OCT) + (String.extract (yytext, 1, NONE)) of + NONE => ErrorMsg.errorAt' (pos yypos, pos yypos) "Illegal string escape" + | SOME n => str := chr n :: !str; + continue()); +<STRING,CHAR> "\\" {xint} => (case StringCvt.scanString (Int.scan StringCvt.HEX) + (String.extract (yytext, 2, NONE)) of + NONE => ErrorMsg.errorAt' (pos yypos, pos yypos) "Illegal string escape" + | SOME n => str := chr n :: !str; + continue()); + +<INITIAL> "#\"" => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue()); + +<CHAR> . => (let + val ch = String.sub (yytext, 0) + in + if ch = !strEnder then + let + val s = String.implode (List.rev (!str)) + in + YYBEGIN INITIAL; + if size s = 1 then + Tokens.CHAR (String.sub (s, 0), !strStart, pos yypos + 1) + else + (ErrorMsg.errorAt' (yypos, yypos) + "Character constant is zero or multiple characters"; + continue ()) + end + else + (str := ch :: !str; + continue ()) + end); + +<INITIAL> "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); +<INITIAL> "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); + +<STRING> . => (let + val ch = String.sub (yytext, 0) + in + if ch = !strEnder then + (if !xmlString then + (xmlString := false; YYBEGIN XMLTAG) + else + YYBEGIN INITIAL; + Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1)) + else + (str := ch :: !str; + continue ()) + end); + +<INITIAL> "<" {xmlid} "/>"=>(let + val tag = String.substring (yytext, 1, size yytext - 3) + in + Tokens.XML_BEGIN_END (tag, yypos, yypos + size yytext) + end); +<INITIAL> "<" {xmlid} ">"=> (let + val tag = String.substring (yytext, 1, size yytext - 2) + in + YYBEGIN XML; + xmlTag := tag :: (!xmlTag); + Tokens.XML_BEGIN (tag, yypos, yypos + size yytext) + end); +<XML> "</" {xmlid} ">" => (let + val id = String.substring (yytext, 2, size yytext - 3) + in + case !xmlTag of + id' :: rest => + if id = id' then + (YYBEGIN INITIAL; + xmlTag := rest; + Tokens.XML_END (yypos, yypos + size yytext)) + else + Tokens.END_TAG (id, yypos, yypos + size yytext) + | _ => + Tokens.END_TAG (id, yypos, yypos + size yytext) + end); + +<XML> "<" {xmlid} => (YYBEGIN XMLTAG; + Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE), + yypos, yypos + size yytext)); + +<XMLTAG> "/" => (Tokens.DIVIDE (yypos, yypos + size yytext)); +<XMLTAG> ">" => (YYBEGIN XML; + Tokens.GT (yypos, yypos + size yytext)); + +<XMLTAG> {ws}+ => (lex ()); + +<XMLTAG> {xmlid} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); +<XMLTAG> "=" => (Tokens.EQ (yypos, yypos + size yytext)); + +<XMLTAG> {intconst} => (case Int64.fromString yytext of + SOME x => Tokens.INT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected int, received: " ^ yytext); + continue ())); +<XMLTAG> {realconst} => (case Real.fromString yytext of + SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected float, received: " ^ yytext); + continue ())); +<XMLTAG> "\"" => (YYBEGIN STRING; + xmlString := true; strEnder := #"\""; + strStart := yypos; str := []; continue ()); + +<XMLTAG> "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XMLTAG); + Tokens.LBRACE (yypos, yypos + 1)); +<XMLTAG> "(" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XMLTAG); + Tokens.LPAREN (yypos, yypos + 1)); + +<XMLTAG> . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML tag character: \"" ^ yytext ^ "\""); + continue ()); + +<XML> "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN XML); + Tokens.LBRACE (yypos, yypos + 1)); + +<XML> {notags} => (Tokens.NOTAGS (unescape (yypos, yypos + size yytext) yytext, yypos, yypos + size yytext)); + +<XML> "(" => (Tokens.NOTAGS ("(", yypos, yypos + size yytext)); + +<XML> . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML character: \"" ^ yytext ^ "\""); + continue ()); + +<INITIAL> "()" => (Tokens.UNIT (pos yypos, pos yypos + size yytext)); +<INITIAL> "(" => (Tokens.LPAREN (pos yypos, pos yypos + size yytext)); +<INITIAL> ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext)); +<INITIAL> "[" => (Tokens.LBRACK (pos yypos, pos yypos + size yytext)); +<INITIAL> "]" => (Tokens.RBRACK (pos yypos, pos yypos + size yytext)); +<INITIAL> "{" => (enterBrace (); + Tokens.LBRACE (pos yypos, pos yypos + size yytext)); +<INITIAL> "}" => (exitBrace (); + Tokens.RBRACE (pos yypos, pos yypos + size yytext)); + +<INITIAL> "-->" => (Tokens.KARROW (pos yypos, pos yypos + size yytext)); +<INITIAL> "->" => (Tokens.ARROW (pos yypos, pos yypos + size yytext)); +<INITIAL> "==>" => (Tokens.DKARROW (pos yypos, pos yypos + size yytext)); +<INITIAL> "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); +<INITIAL> "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); +<INITIAL> "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); +<INITIAL> "---" => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext)); +<INITIAL> "^" => (Tokens.CARET (pos yypos, pos yypos + size yytext)); + +<INITIAL> "&&" => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext)); +<INITIAL> "||" => (Tokens.ORELSE (pos yypos, pos yypos + size yytext)); + +<INITIAL> "<<<" => (Tokens.COMPOSE (pos yypos, pos yypos + size yytext)); +<INITIAL> ">>>" => (Tokens.ANDTHEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "<|" => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext)); +<INITIAL> "|>" => (Tokens.REVAPP (pos yypos, pos yypos + size yytext)); + +<INITIAL> "`" ({cid} ".")* {id} "`" => (Tokens.BACKTICK_PATH ( (* strip backticks *) + substring (yytext,1,size yytext -2), + pos yypos, pos yypos + size yytext)); + +<INITIAL> "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); +<INITIAL> "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); +<INITIAL> "<" => (Tokens.LT (pos yypos, pos yypos + size yytext)); +<INITIAL> ">" => (Tokens.GT (pos yypos, pos yypos + size yytext)); +<INITIAL> "<=" => (Tokens.LE (pos yypos, pos yypos + size yytext)); +<INITIAL> ">=" => (Tokens.GE (pos yypos, pos yypos + size yytext)); +<INITIAL> "," => (Tokens.COMMA (pos yypos, pos yypos + size yytext)); +<INITIAL> ":::_" => (Tokens.TCOLONWILD (pos yypos, pos yypos + size yytext)); +<INITIAL> ":::" => (Tokens.TCOLON (pos yypos, pos yypos + size yytext)); +<INITIAL> "::_" => (Tokens.DCOLONWILD (pos yypos, pos yypos + size yytext)); +<INITIAL> "::" => (Tokens.DCOLON (pos yypos, pos yypos + size yytext)); +<INITIAL> ":" => (Tokens.COLON (pos yypos, pos yypos + size yytext)); +<INITIAL> "..." => (Tokens.DOTDOTDOT (pos yypos, pos yypos + size yytext)); +<INITIAL> "." => (Tokens.DOT (pos yypos, pos yypos + size yytext)); +<INITIAL> "$" => (Tokens.DOLLAR (pos yypos, pos yypos + size yytext)); +<INITIAL> "#" => (Tokens.HASH (pos yypos, pos yypos + size yytext)); +<INITIAL> "__" => (Tokens.UNDERUNDER (pos yypos, pos yypos + size yytext)); +<INITIAL> "_" => (Tokens.UNDER (pos yypos, pos yypos + size yytext)); +<INITIAL> "~" => (Tokens.TWIDDLE (pos yypos, pos yypos + size yytext)); +<INITIAL> "|" => (Tokens.BAR (pos yypos, pos yypos + size yytext)); +<INITIAL> "*" => (Tokens.STAR (pos yypos, pos yypos + size yytext)); +<INITIAL> "<-" => (Tokens.LARROW (pos yypos, pos yypos + size yytext)); +<INITIAL> ";" => (Tokens.SEMI (pos yypos, pos yypos + size yytext)); +<INITIAL> "!" => (Tokens.BANG (pos yypos, pos yypos + size yytext)); + +<INITIAL> "+" => (Tokens.PLUS (pos yypos, pos yypos + size yytext)); +<INITIAL> "-" => (Tokens.MINUS (pos yypos, pos yypos + size yytext)); +<INITIAL> "/" => (Tokens.DIVIDE (yypos, yypos + size yytext)); +<INITIAL> "%" => (Tokens.MOD (pos yypos, pos yypos + size yytext)); +<INITIAL> "@" => (Tokens.AT (pos yypos, pos yypos + size yytext)); + +<INITIAL> "con" => (Tokens.CON (pos yypos, pos yypos + size yytext)); +<INITIAL> "type" => (Tokens.LTYPE (pos yypos, pos yypos + size yytext)); +<INITIAL> "datatype" => (Tokens.DATATYPE (pos yypos, pos yypos + size yytext)); +<INITIAL> "of" => (Tokens.OF (pos yypos, pos yypos + size yytext)); +<INITIAL> "val" => (Tokens.VAL (pos yypos, pos yypos + size yytext)); +<INITIAL> "rec" => (Tokens.REC (pos yypos, pos yypos + size yytext)); +<INITIAL> "and" => (Tokens.AND (pos yypos, pos yypos + size yytext)); +<INITIAL> "fun" => (Tokens.FUN (pos yypos, pos yypos + size yytext)); +<INITIAL> "fn" => (Tokens.FN (pos yypos, pos yypos + size yytext)); +<INITIAL> "map" => (Tokens.MAP (pos yypos, pos yypos + size yytext)); +<INITIAL> "case" => (Tokens.CASE (pos yypos, pos yypos + size yytext)); +<INITIAL> "if" => (Tokens.IF (pos yypos, pos yypos + size yytext)); +<INITIAL> "then" => (Tokens.THEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "else" => (Tokens.ELSE (pos yypos, pos yypos + size yytext)); + + +<INITIAL> "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext)); +<INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext)); +<INITIAL> "struct" => (Tokens.STRUCT (pos yypos, pos yypos + size yytext)); +<INITIAL> "sig" => (if yypos <= 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext)); +<INITIAL> "let" => (Tokens.LET (pos yypos, pos yypos + size yytext)); +<INITIAL> "in" => (Tokens.IN (pos yypos, pos yypos + size yytext)); +<INITIAL> "end" => (Tokens.END (pos yypos, pos yypos + size yytext)); +<INITIAL> "functor" => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext)); +<INITIAL> "where" => (Tokens.WHERE (pos yypos, pos yypos + size yytext)); +<INITIAL> "include" => (Tokens.INCLUDE (pos yypos, pos yypos + size yytext)); +<INITIAL> "open" => (Tokens.OPEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext)); +<INITIAL> "constraints"=> (Tokens.CONSTRAINTS (pos yypos, pos yypos + size yytext)); +<INITIAL> "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); +<INITIAL> "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); +<INITIAL> "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); +<INITIAL> "view" => (Tokens.VIEW (pos yypos, pos yypos + size yytext)); +<INITIAL> "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); +<INITIAL> "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); +<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); +<INITIAL> "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext)); +<INITIAL> "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext)); +<INITIAL> "ffi" => (Tokens.FFI (pos yypos, pos yypos + size yytext)); + +<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); +<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); +<INITIAL> "Unit" => (Tokens.KUNIT (pos yypos, pos yypos + size yytext)); + +<INITIAL> "SELECT" => (Tokens.SELECT (pos yypos, pos yypos + size yytext)); +<INITIAL> "DISTINCT" => (Tokens.DISTINCT (pos yypos, pos yypos + size yytext)); +<INITIAL> "FROM" => (Tokens.FROM (pos yypos, pos yypos + size yytext)); +<INITIAL> "AS" => (Tokens.AS (pos yypos, pos yypos + size yytext)); +<INITIAL> "WHERE" => (Tokens.CWHERE (pos yypos, pos yypos + size yytext)); +<INITIAL> "SQL" => (Tokens.SQL (pos yypos, pos yypos + size yytext)); +<INITIAL> "GROUP" => (Tokens.GROUP (pos yypos, pos yypos + size yytext)); +<INITIAL> "ORDER" => (Tokens.ORDER (pos yypos, pos yypos + size yytext)); +<INITIAL> "BY" => (Tokens.BY (pos yypos, pos yypos + size yytext)); +<INITIAL> "HAVING" => (Tokens.HAVING (pos yypos, pos yypos + size yytext)); +<INITIAL> "LIMIT" => (Tokens.LIMIT (pos yypos, pos yypos + size yytext)); +<INITIAL> "OFFSET" => (Tokens.OFFSET (pos yypos, pos yypos + size yytext)); +<INITIAL> "ALL" => (Tokens.ALL (pos yypos, pos yypos + size yytext)); +<INITIAL> "SELECT1" => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext)); + +<INITIAL> "JOIN" => (Tokens.JOIN (pos yypos, pos yypos + size yytext)); +<INITIAL> "INNER" => (Tokens.INNER (pos yypos, pos yypos + size yytext)); +<INITIAL> "CROSS" => (Tokens.CROSS (pos yypos, pos yypos + size yytext)); +<INITIAL> "OUTER" => (Tokens.OUTER (pos yypos, pos yypos + size yytext)); +<INITIAL> "LEFT" => (Tokens.LEFT (pos yypos, pos yypos + size yytext)); +<INITIAL> "RIGHT" => (Tokens.RIGHT (pos yypos, pos yypos + size yytext)); +<INITIAL> "FULL" => (Tokens.FULL (pos yypos, pos yypos + size yytext)); + +<INITIAL> "UNION" => (Tokens.UNION (pos yypos, pos yypos + size yytext)); +<INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext)); +<INITIAL> "EXCEPT" => (Tokens.EXCEPT (pos yypos, pos yypos + size yytext)); + +<INITIAL> "TRUE" => (Tokens.TRUE (pos yypos, pos yypos + size yytext)); +<INITIAL> "FALSE" => (Tokens.FALSE (pos yypos, pos yypos + size yytext)); +<INITIAL> "AND" => (Tokens.CAND (pos yypos, pos yypos + size yytext)); +<INITIAL> "OR" => (Tokens.OR (pos yypos, pos yypos + size yytext)); +<INITIAL> "NOT" => (Tokens.NOT (pos yypos, pos yypos + size yytext)); + +<INITIAL> "COUNT" => (Tokens.COUNT (pos yypos, pos yypos + size yytext)); +<INITIAL> "AVG" => (Tokens.AVG (pos yypos, pos yypos + size yytext)); +<INITIAL> "SUM" => (Tokens.SUM (pos yypos, pos yypos + size yytext)); +<INITIAL> "MIN" => (Tokens.MIN (pos yypos, pos yypos + size yytext)); +<INITIAL> "MAX" => (Tokens.MAX (pos yypos, pos yypos + size yytext)); +<INITIAL> "RANK" => (Tokens.RANK (pos yypos, pos yypos + size yytext)); +<INITIAL> "PARTITION" => (Tokens.PARTITION (pos yypos, pos yypos + size yytext)); +<INITIAL> "OVER" => (Tokens.OVER (pos yypos, pos yypos + size yytext)); + +<INITIAL> "IF" => (Tokens.CIF (pos yypos, pos yypos + size yytext)); +<INITIAL> "THEN" => (Tokens.CTHEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "ELSE" => (Tokens.CELSE (pos yypos, pos yypos + size yytext)); + +<INITIAL> "ASC" => (Tokens.ASC (pos yypos, pos yypos + size yytext)); +<INITIAL> "DESC" => (Tokens.DESC (pos yypos, pos yypos + size yytext)); +<INITIAL> "RANDOM" => (Tokens.RANDOM (pos yypos, pos yypos + size yytext)); + +<INITIAL> "INSERT" => (Tokens.INSERT (pos yypos, pos yypos + size yytext)); +<INITIAL> "INTO" => (Tokens.INTO (pos yypos, pos yypos + size yytext)); +<INITIAL> "VALUES" => (Tokens.VALUES (pos yypos, pos yypos + size yytext)); +<INITIAL> "UPDATE" => (Tokens.UPDATE (pos yypos, pos yypos + size yytext)); +<INITIAL> "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); +<INITIAL> "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); +<INITIAL> "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); +<INITIAL> "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); +<INITIAL> "COALESCE" => (Tokens.COALESCE (pos yypos, pos yypos + size yytext)); +<INITIAL> "LIKE" => (Tokens.LIKE (pos yypos, pos yypos + size yytext)); + +<INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext)); +<INITIAL> "UNIQUE" => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext)); +<INITIAL> "CHECK" => (Tokens.CHECK (pos yypos, pos yypos + size yytext)); +<INITIAL> "PRIMARY" => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext)); +<INITIAL> "FOREIGN" => (Tokens.FOREIGN (pos yypos, pos yypos + size yytext)); +<INITIAL> "KEY" => (Tokens.KEY (pos yypos, pos yypos + size yytext)); +<INITIAL> "ON" => (Tokens.ON (pos yypos, pos yypos + size yytext)); +<INITIAL> "NO" => (Tokens.NO (pos yypos, pos yypos + size yytext)); +<INITIAL> "ACTION" => (Tokens.ACTION (pos yypos, pos yypos + size yytext)); +<INITIAL> "RESTRICT" => (Tokens.RESTRICT (pos yypos, pos yypos + size yytext)); +<INITIAL> "CASCADE" => (Tokens.CASCADE (pos yypos, pos yypos + size yytext)); +<INITIAL> "REFERENCES"=> (Tokens.REFERENCES (pos yypos, pos yypos + size yytext)); + +<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); + +<INITIAL> "_LOC_" => (let val strLoc = ErrorMsg.spanToString (ErrorMsg.spanOf + (pos yypos, pos yypos + size yytext)) + in + Tokens.STRING (strLoc, pos yypos, pos yypos + size yytext) + end); + +<INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); +<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); + +<INITIAL> {hexconst} => (let val digits = String.extract (yytext, 2, NONE) + val v = (StringCvt.scanString (Int64.scan StringCvt.HEX) digits) + handle Overflow => NONE + in + case v of + SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected hexInt, received: " ^ yytext); + continue ()) + end); + +<INITIAL> {intconst} => (let val v = (Int64.fromString yytext) handle Overflow => NONE + in + case v of + SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected int, received: " ^ yytext); + continue ()) + end); +<INITIAL> {realconst} => (case Real64.fromString yytext of + SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected float, received: " ^ yytext); + continue ())); + +<COMMENT> . => (continue()); + +<INITIAL> . => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("illegal character: \"" ^ yytext ^ "\""); + continue ()); diff --git a/src/utf8.sig b/src/utf8.sig new file mode 100644 index 0000000..4198f60 --- /dev/null +++ b/src/utf8.sig @@ -0,0 +1,32 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* UTF-8 conversion *) + +signature UTF8 = sig + val encode : int -> string +end diff --git a/src/utf8.sml b/src/utf8.sml new file mode 100644 index 0000000..cbd2fa5 --- /dev/null +++ b/src/utf8.sml @@ -0,0 +1,59 @@ +(* Copyright (c) 2011, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* UTF-8 conversion *) + +structure Utf8 :> UTF8 = struct + +fun byte n = str (chr (Word.toInt n)) + +fun encode n = + if n <= 0 then + raise Fail "Invalid character to UTF-8-encode" + else if n <= 0x7F then + str (chr n) + else if n <= 0x7FF then + let + val w = Word.fromInt n + val b1 = Word.orb (Word.fromInt (128 + 64), Word.>> (w, Word.fromInt 6)) + val b2 = Word.orb (Word.fromInt 128, Word.andb (w, Word.fromInt 63)) + in + byte b1 ^ byte b2 + end + else if n <= 0xFFFF then + let + val w = Word.fromInt n + val b1 = Word.orb (Word.fromInt (128 + 64 + 32), Word.>> (w, Word.fromInt 12)) + val b2 = Word.orb (Word.fromInt 128, Word.andb (Word.>> (w, Word.fromInt 6), Word.fromInt 63)) + val b3 = Word.orb (Word.fromInt 128, Word.andb (w, Word.fromInt 63)) + in + byte b1 ^ byte b2 ^ byte b3 + end + else + raise Fail "Exceeded supported range for UTF-8 characters" + +end |