diff options
author | Ziv Scully <ziv@mit.edu> | 2014-05-27 21:38:01 -0400 |
---|---|---|
committer | Ziv Scully <ziv@mit.edu> | 2014-05-27 21:38:01 -0400 |
commit | dc336268adfbf2b05b34ab006de5990f8ce9086c (patch) | |
tree | 22fb72ef5ad32f47571fa250515108188d7e22f9 /src | |
parent | d941d873c0203009ccf44aa4aed97671703ca375 (diff) | |
parent | 4cee29f03879d25963e3d8a8dda879e0a007033c (diff) |
Merge.
Diffstat (limited to 'src')
-rw-r--r-- | src/c/cgi.c | 6 | ||||
-rw-r--r-- | src/c/fastcgi.c | 13 | ||||
-rw-r--r-- | src/c/http.c | 14 | ||||
-rw-r--r-- | src/c/request.c | 40 | ||||
-rw-r--r-- | src/c/static.c | 6 | ||||
-rw-r--r-- | src/c/urweb.c | 117 | ||||
-rw-r--r-- | src/compiler.sml | 1 | ||||
-rw-r--r-- | src/corify.sml | 75 | ||||
-rw-r--r-- | src/elab.sml | 3 | ||||
-rw-r--r-- | src/elab_env.sml | 1 | ||||
-rw-r--r-- | src/elab_err.sig | 1 | ||||
-rw-r--r-- | src/elab_err.sml | 4 | ||||
-rw-r--r-- | src/elab_print.sml | 1 | ||||
-rw-r--r-- | src/elab_util.sml | 8 | ||||
-rw-r--r-- | src/elaborate.sml | 22 | ||||
-rw-r--r-- | src/elisp/urweb-mode.el | 2 | ||||
-rw-r--r-- | src/expl.sml | 1 | ||||
-rw-r--r-- | src/expl_env.sml | 1 | ||||
-rw-r--r-- | src/expl_print.sml | 1 | ||||
-rw-r--r-- | src/expl_rename.sml | 10 | ||||
-rw-r--r-- | src/explify.sml | 1 | ||||
-rw-r--r-- | src/jscomp.sig | 4 | ||||
-rw-r--r-- | src/jscomp.sml | 12 | ||||
-rw-r--r-- | src/main.mlton.sml | 3 | ||||
-rw-r--r-- | src/mono_opt.sml | 10 | ||||
-rw-r--r-- | src/monoize.sml | 71 | ||||
-rw-r--r-- | src/settings.sig | 7 | ||||
-rw-r--r-- | src/settings.sml | 9 | ||||
-rw-r--r-- | src/source.sml | 10 | ||||
-rw-r--r-- | src/source_print.sml | 23 | ||||
-rw-r--r-- | src/unnest.sml | 1 | ||||
-rw-r--r-- | src/urweb.grm | 235 | ||||
-rw-r--r-- | src/urweb.lex | 1 |
33 files changed, 541 insertions, 173 deletions
diff --git a/src/c/cgi.c b/src/c/cgi.c index 539b83c2..d060532c 100644 --- a/src/c/cgi.c +++ b/src/c/cgi.c @@ -60,8 +60,10 @@ static void log_error(void *data, const char *fmt, ...) { 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, NULL, log_error, log_debug); + 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"), @@ -108,7 +110,7 @@ int main(int argc, char *argv[]) { uw_set_on_success(""); uw_set_headers(ctx, get_header, NULL); uw_set_env(ctx, get_env, NULL); - uw_request_init(&uw_application, NULL, log_error, log_debug); + uw_request_init(&uw_application, &ls); body[body_pos] = 0; rr = uw_request(rc, ctx, method, path, query_string, body, body_pos, diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index 5c80d3ae..f3e66e3a 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -324,7 +324,8 @@ int fastcgi_send_normal(int sock, const void *buf, ssize_t len) { static void *worker(void *data) { FCGI_Input *in = fastcgi_input(); FCGI_Output *out = fastcgi_output(); - uw_context ctx = uw_request_new_context(*(int *)data, &uw_application, out, log_error, log_debug); + 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; @@ -514,7 +515,7 @@ static void sigint(int signum) { exit(0); } -static loggers ls = {&uw_application, NULL, log_error, log_debug}; +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. @@ -563,7 +564,7 @@ int main(int argc, char *argv[]) { } uw_set_on_success(""); - uw_request_init(&uw_application, NULL, log_error, log_debug); + uw_request_init(&uw_application, &ls); names = calloc(nthreads, sizeof(int)); @@ -572,7 +573,11 @@ int main(int argc, char *argv[]) { { pthread_t thread; - if (pthread_create_big(&thread, NULL, client_pruner, &ls)) { + 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; } diff --git a/src/c/http.c b/src/c/http.c index 25d2a320..32dd1dd1 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -70,9 +70,11 @@ static void log_debug(void *data, const char *fmt, ...) { } } +static uw_loggers ls = {NULL, log_error, log_debug}; + static void *worker(void *data) { int me = *(int *)data; - uw_context ctx = uw_request_new_context(me, &uw_application, NULL, log_error, log_debug); + 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(); @@ -307,8 +309,6 @@ static void sigint(int signum) { exit(0); } -static loggers ls = {&uw_application, NULL, log_error, log_debug}; - int main(int argc, char *argv[]) { // The skeleton for this function comes from Beej's sockets tutorial. int sockfd; // listen on sock_fd @@ -374,7 +374,7 @@ int main(int argc, char *argv[]) { } } - uw_request_init(&uw_application, NULL, log_error, log_debug); + uw_request_init(&uw_application, &ls); names = calloc(nthreads, sizeof(int)); @@ -411,7 +411,11 @@ int main(int argc, char *argv[]) { { pthread_t thread; - if (pthread_create_big(&thread, NULL, client_pruner, &ls)) { + 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; } diff --git a/src/c/request.c b/src/c/request.c index b925cc3c..813d967c 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -12,6 +12,7 @@ #include <pthread.h> #include "urweb.h" +#include "request.h" #define MAX_RETRIES 5 @@ -32,8 +33,11 @@ static int try_rollback(uw_context ctx, int will_retry, void *logger_data, uw_lo return r; } -uw_context uw_request_new_context(int id, uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) { - uw_context ctx = uw_init(id, logger_data, log_debug); +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; uw_set_app(ctx, app); @@ -78,20 +82,15 @@ static void *ticker(void *data) { } typedef struct { - uw_app *app; - void *logger_data; - uw_logger log_error, log_debug; -} loggers; - -typedef struct { int id; - loggers *ls; + 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->ls->app, p->ls->logger_data, p->ls->log_error, p->ls->log_debug); + uw_context ctx = uw_request_new_context(p->id, p->app, p->ls); if (!ctx) exit(1); @@ -145,14 +144,17 @@ int pthread_create_big(pthread_t *outThread, void *foo, void *threadFunc, void * } } -void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) { +void uw_request_init(uw_app *app, uw_loggers* ls) { uw_context ctx; failure_kind fk; uw_periodic *ps; - loggers *ls = malloc(sizeof(loggers)); 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); @@ -162,11 +164,6 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log } } - ls->app = app; - ls->logger_data = logger_data; - ls->log_error = log_error; - ls->log_debug = log_debug; - uw_global_init(); uw_app_init(app); @@ -179,7 +176,7 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log } } - ctx = uw_request_new_context(0, app, logger_data, log_error, log_debug); + ctx = uw_request_new_context(0, app, ls); if (!ctx) exit(1); @@ -205,6 +202,7 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log 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"); @@ -240,7 +238,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx, 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, size_t len), + int (*send)(int sockfd, const void *buf, ssize_t len), int (*close)(int fd)) { int retries_left = MAX_RETRIES; failure_kind fk; @@ -588,8 +586,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx, } void *client_pruner(void *data) { - loggers *ls = (loggers *)data; - uw_context ctx = uw_request_new_context(0, ls->app, ls->logger_data, ls->log_error, ls->log_debug); + pruner_data *pd = (pruner_data *)data; + uw_context ctx = uw_request_new_context(0, pd->app, pd->loggers); if (!ctx) exit(1); diff --git a/src/c/static.c b/src/c/static.c index 80ea5387..8f35a2d4 100644 --- a/src/c/static.c +++ b/src/c/static.c @@ -7,13 +7,15 @@ extern uw_app uw_application; -static void log_debug(void *data, const char *fmt, ...) { +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_}; + int main(int argc, char *argv[]) { uw_context ctx; failure_kind fk; @@ -23,7 +25,7 @@ int main(int argc, char *argv[]) { return 1; } - ctx = uw_init(0, NULL, log_debug); + ctx = uw_init(0, &loggers); uw_set_app(ctx, &uw_application); uw_initialize(ctx); diff --git a/src/c/urweb.c b/src/c/urweb.c index d4c0b439..78afcd05 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -460,8 +460,7 @@ struct uw_context { void *client_data; - void *logger_data; - uw_logger log_debug; + uw_loggers *loggers; int isPost, hasPostBody; uw_Basis_postBody postBody; @@ -487,7 +486,7 @@ 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, void *logger_data, uw_logger log_debug) { +uw_context uw_init(int id, uw_loggers *lg) { uw_context ctx = malloc(sizeof(struct uw_context)); ctx->app = NULL; @@ -546,8 +545,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) { ctx->client_data = uw_init_client_data(); - ctx->logger_data = logger_data; - ctx->log_debug = log_debug; + ctx->loggers = lg; ctx->isPost = ctx->hasPostBody = 0; @@ -601,6 +599,11 @@ 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; @@ -1258,17 +1261,34 @@ 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 % 4 != 0) { + size_t bump = 4 - posn % 4; + 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) { - result = malloc(len); + int error = posix_memalign(&result, 4, len); - if (result) + if (!error) return result; else - uw_error(ctx, FATAL, "uw_malloc: malloc() returns 0"); + uw_error(ctx, FATAL, "uw_malloc: posix_memalign() returns %d", error); } else { + align_heap(ctx); + uw_check_heap(ctx, len); result = ctx->heap.front; @@ -1278,6 +1298,8 @@ void *uw_malloc(uw_context ctx, size_t len) { } void uw_begin_region(uw_context ctx) { + align_heap(ctx); + regions *r = (regions *) ctx->heap.front; uw_check_heap(ctx, sizeof(regions)); @@ -1588,6 +1610,9 @@ 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; @@ -3316,32 +3341,58 @@ int uw_commit(uw_context ctx) { } } - 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; - } - } - if (ctx->transaction_started) { int code = ctx->app->db_commit(ctx); if (code) { - if (code == -1) + 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); + 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->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); @@ -3455,11 +3506,12 @@ int uw_commit(uw_context ctx) { size_t uw_transactionals_max = SIZE_MAX; -void uw_register_transactional(uw_context ctx, void *data, uw_callback commit, uw_callback rollback, +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) - uw_error(ctx, FATAL, "Exceeded limit on number of transactionals"); + // Exceeded limit on number of transactionals. + return -1; ctx->transactionals = realloc(ctx->transactionals, sizeof(transactional) * (ctx->used_transactionals+1)); ++ctx->n_transactionals; } @@ -3468,6 +3520,8 @@ void uw_register_transactional(uw_context ctx, void *data, uw_callback commit, u ctx->transactionals[ctx->used_transactionals].commit = commit; ctx->transactionals[ctx->used_transactionals].rollback = rollback; ctx->transactionals[ctx->used_transactionals++].free = free; + + return 0; } @@ -3965,7 +4019,8 @@ uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) { 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_hour = hour, .tm_min = minute, .tm_sec = second, + .tm_isdst = -1 }; uw_Basis_time r = { timelocal(&tm) }; return r; } @@ -4136,8 +4191,8 @@ uw_Basis_int uw_Basis_naughtyDebug(uw_context ctx, uw_Basis_string s) { } uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { - if (ctx->log_debug) - ctx->log_debug(ctx->logger_data, "%s\n", 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; @@ -4379,3 +4434,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) { 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; +} diff --git a/src/compiler.sml b/src/compiler.sml index 37272758..fd143485 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -874,6 +874,7 @@ fun parseUrp' accLibs fname = | "timeFormat" => Settings.setTimeFormat arg | "noMangleSql" => Settings.setMangleSql false | "html5" => Settings.setIsHtml5 true + | "lessSafeFfi" => Settings.setLessSafeFfi true | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () diff --git a/src/corify.sml b/src/corify.sml index 085b2eb8..b08ef7eb 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -643,6 +643,12 @@ fun 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) => @@ -970,12 +976,6 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = in transactify c end - - fun isTransactional (c, _) = - case c of - L'.TFun (_, c) => isTransactional c - | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true - | _ => false in if isTransactional c then let @@ -1164,6 +1164,66 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ([], 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 e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc) + val (e, tTrans) = if isTransactional t' 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 isTransactional t' 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 => @@ -1237,7 +1297,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DStyle (_, _, n') => Int.max (n, n') | L.DTask _ => n | L.DPolicy _ => n - | L.DOnError _ => n) + | L.DOnError _ => n + | L.DFfi (_, n', _, _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/elab.sml b/src/elab.sml index 2dab5c34..249531f1 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -181,6 +181,7 @@ datatype decl' = | 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 diff --git a/src/elab_env.sml b/src/elab_env.sml index 465fb7e4..9fbe7bd7 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1681,5 +1681,6 @@ fun declBinds env (d, loc) = | 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 index b5e3d64d..acf137df 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -81,6 +81,7 @@ signature ELAB_ERR = sig | 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 diff --git a/src/elab_err.sml b/src/elab_err.sml index 4754d4ce..33daa118 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -180,6 +180,7 @@ datatype exp_error = | 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)), @@ -251,6 +252,9 @@ fun expError env err = (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 = diff --git a/src/elab_print.sml b/src/elab_print.sml index 7ce94c97..957d4646 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -852,6 +852,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 60245585..fef55852 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -927,7 +927,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))) | DTask _ => ctx | DPolicy _ => ctx - | DOnError _ => 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 @@ -1056,6 +1057,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f 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, @@ -1234,6 +1239,7 @@ and maxNameDecl (d, _) = | DTask _ => 0 | DPolicy _ => 0 | DOnError _ => 0 + | DFfi (_, n, _, _) => n and maxNameStr (str, _) = case str of StrConst ds => maxName ds diff --git a/src/elaborate.sml b/src/elaborate.sml index 5dd86f18..d492883f 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2183,8 +2183,13 @@ fun elabExp (env, denv) (eAll as (e, loc)) = (e', (#1 (chaseUnifs t'), loc), enD gs2 @ gs1) end - | L.ERecord xes => + | 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 @@ -2994,6 +2999,7 @@ and sgiOfDecl (d, 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), @@ -4293,6 +4299,20 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = ([(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), diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index f183a9ab..edbff1b0 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -139,7 +139,7 @@ See doc for the variable `urweb-mode-info'." "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy" "struct" "structure" "table" "view" "then" "type" "val" "where" - "with" + "with" "ffi" "Name" "Type" "Unit") "A regexp that matches any non-SQL keywords of Ur/Web.") diff --git a/src/expl.sml b/src/expl.sml index 0d4e63cc..3d784e3f 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -150,6 +150,7 @@ datatype decl' = | 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 diff --git a/src/expl_env.sml b/src/expl_env.sml index f5a5eb0a..5712a72d 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -346,6 +346,7 @@ fun declBinds env (d, loc) = | DTask _ => env | DPolicy _ => env | DOnError _ => env + | DFfi (x, n, _, t) => pushENamed env x n t fun sgiBinds env (sgi, loc) = case sgi of diff --git a/src/expl_print.sml b/src/expl_print.sml index a830dccb..22d246e2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -731,6 +731,7 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of diff --git a/src/expl_rename.sml b/src/expl_rename.sml index 7e7a155a..bb763a60 100644 --- a/src/expl_rename.sml +++ b/src/expl_rename.sml @@ -219,6 +219,7 @@ fun renameDecl st (all as (d, loc)) = (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 @@ -413,6 +414,15 @@ fun dupDecl (all as (d, loc), st) = (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 diff --git a/src/explify.sml b/src/explify.sml index 4c60bd20..fd0f3277 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -198,6 +198,7 @@ fun explifyDecl (d, loc : EM.span) = | 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 diff --git a/src/jscomp.sig b/src/jscomp.sig index 929c507d..5b8723b4 100644 --- a/src/jscomp.sig +++ b/src/jscomp.sig @@ -29,4 +29,8 @@ 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 index 4a2c0365..bcabed0b 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -41,6 +41,8 @@ structure TM = BinaryMapFn(struct val compare = U.Typ.compare end) +val explainEmbed = ref false + type state = { decls : (string * int * (string * int * typ option) list) list, script : string list, @@ -267,7 +269,12 @@ fun process (file : file) = ((EApp ((ENamed n', loc), e), loc), st) end) - | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*) + | _ => (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) = @@ -400,6 +407,9 @@ fun process (file : file) = 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 = diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 71fefc48..bfc18e59 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -174,6 +174,9 @@ fun oneRun args = 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) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 228c53e6..ae306e68 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -118,6 +118,9 @@ fun unAs 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 = #"-" @@ -442,6 +445,13 @@ fun exp e = | 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 () diff --git a/src/monoize.sml b/src/monoize.sml index 000ba7b6..f7344fed 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2013, Adam Chlipala +(* Copyright (c) 2008-2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -235,6 +235,7 @@ fun monoType env = | 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", "data_attr") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) => (L'.TFfi ("Basis", "string"), loc) @@ -2131,7 +2132,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ "" + ^ "." ^ Settings.mangleSql x')) xts)) grouped) ], @@ -3117,6 +3118,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat ((L'.EPrim (Prim.String "data-"), loc), + (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), + (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc), + (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), + (L'.EPrim (Prim.String "\""), loc)), 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 ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + fm) + end + | L.EFfiApp ("Basis", "css_url", [(s, _)]) => let val (s, fm) = monoExp (env, st, fm) s @@ -3206,7 +3230,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "tag"), - _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _), class), _), dynClass), _), style), _), @@ -3317,6 +3341,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s, fm) = foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc + | (("Data", e, _), (s, fm)) => + ((L'.EStrcat (s, + (L'.EStrcat ( + (L'.EPrim (Prim.String " "), loc), + e), loc)), loc), + fm) | ((x, e, t), (s, fm)) => case t of (L'.TFfi ("Basis", "bool"), _) => @@ -3551,6 +3581,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EPrim (Prim.String ")"), loc)), 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" + val baseAll as (base, fm) = case tag of "body" => let @@ -3573,24 +3616,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "dyn" => let - fun inTag tag = case targs of - (L.CRecord (_, ctx), _) :: _ => - List.exists (fn ((L.CName tag', _), _) => tag' = tag - | _ => false) ctx - | _ => false - - val tag = if inTag "Tr" then - "tr" - else if inTag "Table" then - "table" - else - "span" in case attrs of [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" - ^ tag ^ "\", execD(")), loc), + ^ pnode () ^ "\", execD(")), loc), (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), fm) @@ -3804,7 +3835,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = L'.ENone _ => (case #1 dynStyle of L'.ENone _ => baseAll - | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(", + | 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), @@ -3822,7 +3855,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; str "null") in - (strcat [str "<script type=\"text/javascript\">dynClass(execD(", + (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), diff --git a/src/settings.sig b/src/settings.sig index 20dd00c2..29c4c506 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -78,18 +78,22 @@ signature SETTINGS = sig (* 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 setJsFuncs : (ffi * string) list -> unit + val addJsFunc : ffi * string -> unit val jsFunc : ffi -> string option val allJsFuncs : unit -> (ffi * string) list @@ -271,4 +275,7 @@ signature SETTINGS = sig val setIsHtml5 : bool -> unit val getIsHtml5 : unit -> bool + + val setLessSafeFfi : bool -> unit + val getLessSafeFfi : unit -> bool end diff --git a/src/settings.sml b/src/settings.sml index 6282577d..f00a4853 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -194,6 +194,7 @@ val benignBase = basis ["get_cookie", 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", @@ -225,6 +226,7 @@ val clientBase = basis ["get_client_source", "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", @@ -240,6 +242,7 @@ val serverBase = basis ["requestHeader", "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 @@ -309,6 +312,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("checkUrl", "checkUrl"), ("bless", "bless"), + ("blessData", "blessData"), ("eq_time", "eq"), ("lt_time", "lt"), @@ -363,6 +367,7 @@ val jsFuncsBase = basisM [("alert", "alert"), val jsFuncs = ref jsFuncsBase fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) +fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v) fun allJsFuncs () = M.listItemsi (!jsFuncs) datatype pattern_kind = Exact | Prefix @@ -734,4 +739,8 @@ val html5 = ref false fun setIsHtml5 b = html5 := b fun getIsHtml5 () = !html5 +val less = ref false +fun setLessSafeFfi b = less := b +fun getLessSafeFfi () = !less + end diff --git a/src/source.sml b/src/source.sml index 639ea716..2a741dd9 100644 --- a/src/source.sml +++ b/src/source.sml @@ -125,7 +125,7 @@ and exp' = | EKAbs of string * exp - | ERecord of (con * exp) list + | ERecord of (con * exp) list * bool | EField of exp * con | EConcat of exp * exp | ECut of exp * con @@ -147,6 +147,13 @@ 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 @@ -169,6 +176,7 @@ datatype decl' = | 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 diff --git a/src/source_print.sml b/src/source_print.sml index ce095542..db56a0db 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -277,14 +277,20 @@ fun p_exp' par (e, _) = space, string "!"]) - | ERecord xes => box [string "{", - p_list (fn (x, e) => - box [p_name x, - space, - string "=", - space, - p_exp e]) xes, - 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] @@ -668,6 +674,7 @@ fun p_decl ((d, _) : decl) = space, p_exp e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str (str, _) = case str of diff --git a/src/unnest.sml b/src/unnest.sml index 17bfd39f..fceb5026 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -452,6 +452,7 @@ fun unnest file = | DTask _ => explore () | DPolicy _ => explore () | DOnError _ => default () + | DFfi _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 7063af38..157ecfac 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -225,7 +225,7 @@ fun tagIn bt = datatype prop_kind = Delete | Update -datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp +datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp fun patType loc (p : pat) = case #1 p of @@ -322,6 +322,39 @@ fun applyWindow loc e window = (EApp (e', ob), loc) end +fun patternOut (e : exp) = + case #1 e of + EWild => (PWild, #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"; + (PWild, #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."; + (PWild, #2 e)) + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -332,7 +365,7 @@ fun applyWindow loc e window = | 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 + | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI | DATATYPE | OF | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG @@ -428,13 +461,13 @@ fun applyWindow loc e window = | eapps of exp | eterm of exp | etuple of exp list - | rexp of (con * exp) list + | rexp of (con * exp) list * bool | xml of exp | xmlOne of exp | xmlOpt of exp | tag of (string * exp) * exp option * exp option * exp | tagHead of string * exp - | bind of string * con option * exp + | bind of pat * con option * exp | edecl of edecl | edecls of edecl list @@ -453,7 +486,7 @@ fun applyWindow loc e window = | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of exp option * exp option * exp option * exp option * (con * exp) list + | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list | attr of attr | attrv of exp @@ -499,6 +532,9 @@ fun applyWindow loc e window = | 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 *) @@ -612,6 +648,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | 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) @@ -730,10 +767,10 @@ cst : UNIQUE tnames (let 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)], loc)), loc) + (EApp (e, (ERecord ([((CName "OnDelete", loc), + findMode Delete), + ((CName "OnUpdate", loc), + findMode Update)], false), loc)), loc) end) | LBRACE eexp RBRACE (eexp) @@ -779,7 +816,7 @@ pk : LBRACE LBRACE eexp RBRACE RBRACE (eexp) val witness = map (fn (c, _) => (c, (EWild, loc))) (#1 tnames :: #2 tnames) - val witness = (ERecord witness, loc) + val witness = (ERecord (witness, false), loc) in (EApp (e, witness), loc) end) @@ -1136,11 +1173,17 @@ eexp : eapps (case #1 eapps of end) | bind SEMI eexp (let val loc = s (bindleft, eexpright) - val (v, to, e1) = bind + 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, (EAbs (v, to, eexp), loc)), loc) + (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))) @@ -1181,17 +1224,17 @@ eexp : eapps (case #1 eapps of val loc = s (eappsleft, eexpright) in (EApp ((EVar (["Basis"], "Cons", Infer), loc), - (ERecord [((CName "1", loc), - eapps), - ((CName "2", loc), - eexp)], loc)), loc) + (ERecord ([((CName "1", loc), + eapps), + ((CName "2", loc), + eexp)], false), loc)), loc) end) -bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) +bind : eapps LARROW eapps (patternOut eapps1, NONE, eapps2) | eapps (let val loc = s (eappsleft, eappsright) in - ("_", SOME (TRecord (CRecord [], loc), loc), eapps) + ((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps) end) eargs : earg (earg) @@ -1289,7 +1332,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) in (ERecord (ListUtil.mapi (fn (i, e) => ((CName (Int.toString (i + 1)), loc), - e)) etuple), loc) + e)) etuple, false), loc) end) | path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) @@ -1299,7 +1342,8 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | 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)) - | UNIT (ERecord [], s (UNITleft, UNITright)) + | 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)) @@ -1386,7 +1430,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) ^ " vs. " ^ Int.toString (length sqlexps) ^ ")") else (); - (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc) + (EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc) end) | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN (let @@ -1394,7 +1438,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, 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, loc)), loc) + val e = (EApp (e, (ERecord (fsets, false), loc)), loc) val e = (EApp (e, texp), loc) in (EApp (e, sqlexp), loc) @@ -1486,9 +1530,9 @@ rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false) ptuple : pat COMMA pat ([pat1, pat2]) | pat COMMA ptuple (pat :: ptuple) -rexp : ([]) - | ident EQ eexp ([(ident, eexp)]) - | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp) +rexp : DOTDOTDOT ([], true) + | ident EQ eexp ([(ident, eexp)], false) + | ident EQ eexp COMMA rexp ((ident, eexp) :: #1 rexp, #2 rexp) xml : xmlOne xml (let val pos = s (xmlOneleft, xmlright) @@ -1602,9 +1646,33 @@ tag : tagHead attrs (let | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), e), pos) val e = (EApp (e, eo), pos) - val e = (EApp (e, (ERecord (#5 attrs), pos)), pos) + + val atts = case #5 attrs of + [] => #6 attrs + | data :: datas => + let + fun doOne (name, value) = + let + val e = (EVar (["Basis"], "data_attr", Infer), pos) + val e = (EApp (e, (EPrim (Prim.String 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') :: #6 attrs + end + + val e = (EApp (e, (ERecord (atts, false), pos)), pos) val e = (EApp (e, (EApp (#2 tagHead, - (ERecord [], pos)), pos)), pos) + (ERecord ([], false), pos)), pos)), pos) in (tagHead, #1 attrs, #2 attrs, e) end) @@ -1618,7 +1686,7 @@ tagHead: BEGIN_TAG (let end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : (NONE, NONE, NONE, NONE, []) +attrs : (NONE, NONE, NONE, NONE, [], []) | attr attrs (let val loc = s (attrleft, attrsright) in @@ -1627,24 +1695,26 @@ attrs : (NONE, NONE, NONE, NONE, []) (case #1 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; - (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs)) + (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 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)) + (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 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)) + (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 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)) + (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs)) + | Data xe => + (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs) | Normal xe => - (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs) + (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs) end) attr : SYMBOL EQ attrv (case SYMBOL of @@ -1653,23 +1723,26 @@ attr : SYMBOL EQ attrv (case SYMBOL of | "style" => Style attrv | "dynStyle" => DynStyle attrv | _ => - 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 - attrv) - end) + if String.isPrefix "data-" SYMBOL then + Data (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 + attrv) + end) attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) @@ -1679,14 +1752,14 @@ attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTri 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)], loc) + 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) @@ -1767,21 +1840,21 @@ query1 : SELECT dopt select FROM tables wopt gopt hopt 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, 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 @@ -1907,6 +1980,7 @@ fitem : table' ([#1 table'], #2 table') in ([tname], (EApp (e, query), loc)) end) + | LPAREN fitem RPAREN (fitem) tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) | LBRACE cexp RBRACE (cexp) @@ -2197,3 +2271,16 @@ 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 index 293c6dc6..15ae448e 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -445,6 +445,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <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)); |