From a2495d384c7747a079cb0f4bc31f44d626391068 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 14:03:12 -0400 Subject: Metaform demos, minus prose --- src/cjr_print.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f2af999b..089f98a1 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1466,7 +1466,8 @@ fun p_file env (ds, ps) = let fun unurlify' rf t = case t of - TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + TFfi ("Basis", "unit") => string ("uw_unit_v") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") | TRecord 0 => string "uw_unit_v" | TRecord i => -- cgit v1.2.3 From 4f82b8197a0e0b520882c0173f321bd948fc7b50 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 16:47:18 -0400 Subject: Transactions seem to be working --- .hgignore | 2 ++ src/c/driver.c | 56 ++++++++++++++++++++++++++++++++++++++++- src/cjr_print.sml | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/aborter.sql | 3 +++ tests/aborter.ur | 5 ++++ tests/aborter.urp | 4 +++ 6 files changed, 144 insertions(+), 1 deletion(-) create mode 100644 tests/aborter.sql create mode 100644 tests/aborter.ur create mode 100644 tests/aborter.urp (limited to 'src/cjr_print.sml') diff --git a/.hgignore b/.hgignore index f6368700..8c3417d4 100644 --- a/.hgignore +++ b/.hgignore @@ -24,3 +24,5 @@ src/config.sml demo/out/*.html demo/demo.* + +*.sql diff --git a/src/c/driver.c b/src/c/driver.c index 09478270..db982d96 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -51,6 +51,24 @@ static pthread_cond_t queue_cond = PTHREAD_COND_INITIALIZER; #define MAX_RETRIES 5 +int uw_db_begin(uw_context); +int uw_db_commit(uw_context); +int uw_db_rollback(uw_context); + +static int try_rollback(uw_context ctx) { + int r = uw_db_rollback(ctx); + + if (r) { + printf("Error running SQL ROLLBACK\n"); + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL ROLLBACK\n"); + } + + return r; +} + static void *worker(void *data) { int me = *(int *)data, retries_left = MAX_RETRIES; uw_context ctx = uw_init(1024, 0); @@ -116,6 +134,7 @@ static void *worker(void *data) { *back = 0; if (s = strstr(buf, "\r\n\r\n")) { + failure_kind fk; char *cmd, *path, path_copy[uw_bufsize+1], *inputs; *s = 0; @@ -169,7 +188,20 @@ static void *worker(void *data) { printf("Serving URI %s....\n", path); while (1) { - failure_kind fk; + if (uw_db_begin(ctx)) { + printf("Error running SQL BEGIN\n"); + if (retries_left) + --retries_left; + else { + fk = FATAL; + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL BEGIN\n"); + + break; + } + } uw_write(ctx, "HTTP/1.1 200 OK\r\n"); uw_write(ctx, "Content-type: text/html\r\n\r\n"); @@ -179,6 +211,17 @@ static void *worker(void *data) { fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { uw_write(ctx, ""); + + if (uw_db_commit(ctx)) { + fk = FATAL; + + printf("Error running SQL COMMIT\n"); + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL COMMIT\n"); + } + break; } else if (fk == BOUNDED_RETRY) { if (retries_left) { @@ -194,6 +237,10 @@ static void *worker(void *data) { uw_write(ctx, "Fatal error (out of retries): "); uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); + + try_rollback(ctx); + + break; } } else if (fk == UNLIMITED_RETRY) printf("Error triggers unlimited retry: %s\n", uw_error_message(ctx)); @@ -207,6 +254,8 @@ static void *worker(void *data) { uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); + try_rollback(ctx); + break; } else { printf("Unknown uw_handle return code!\n"); @@ -216,10 +265,15 @@ static void *worker(void *data) { uw_write(ctx, "Content-type: text/plain\r\n\r\n"); uw_write(ctx, "Unknown uw_handle return code!\n"); + try_rollback(ctx); + break; } uw_reset_keep_request(ctx); + + if (try_rollback(ctx)) + break; } uw_send(ctx, sock); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 089f98a1..7d74376e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1268,6 +1268,75 @@ fun p_decl env (dAll as (d, _) : decl) = string "PQfinish(uw_get_db(ctx));", newline, string "}", + newline, + newline, + + string "int uw_db_begin(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"BEGIN\");", + 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 "return 0;", + newline, + string "}", + newline, + newline, + + string "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 "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "return 0;", + newline, + string "}", + newline, + newline, + + string "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 "return 0;", + newline, + string "}", newline] | DPreparedStatements ss => @@ -2158,6 +2227,12 @@ fun p_file env (ds, ps) = else box [newline, string "void uw_db_init(uw_context ctx) { };", + newline, + string "int uw_db_begin(uw_context ctx) { return 0; };", + newline, + string "int uw_db_commit(uw_context ctx) { return 0; };", + newline, + string "int uw_db_rollback(uw_context ctx) { return 0; };", newline]] end diff --git a/tests/aborter.sql b/tests/aborter.sql new file mode 100644 index 00000000..ab6110fc --- /dev/null +++ b/tests/aborter.sql @@ -0,0 +1,3 @@ +CREATE TABLE uw_Aborter_t(uw_a int8 NOT NULL); + + \ No newline at end of file diff --git a/tests/aborter.ur b/tests/aborter.ur new file mode 100644 index 00000000..0921bdfc --- /dev/null +++ b/tests/aborter.ur @@ -0,0 +1,5 @@ +table t : {A : int} + +fun main () : transaction page = + () <- dml (INSERT INTO t (A) VALUES (0)); + return (error No way, Jose!) diff --git a/tests/aborter.urp b/tests/aborter.urp new file mode 100644 index 00000000..fc1925ae --- /dev/null +++ b/tests/aborter.urp @@ -0,0 +1,4 @@ +database dbname=aborter +sql aborter.sql + +aborter -- cgit v1.2.3 From 6e9d4b27c527465c6df34d35e4d85dc3162db7c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 17:30:07 -0400 Subject: Properly freeing libpq results on errors --- demo/sql.urp | 1 + include/urweb.h | 25 +++++++++++++------------ src/c/urweb.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ src/cjr_print.sml | 4 +++- tests/aborter2.ur | 7 +++++++ tests/aborter2.urp | 5 +++++ 6 files changed, 73 insertions(+), 13 deletions(-) create mode 100644 tests/aborter2.ur create mode 100644 tests/aborter2.urp (limited to 'src/cjr_print.sml') diff --git a/demo/sql.urp b/demo/sql.urp index 7894da95..06fbbd24 100644 --- a/demo/sql.urp +++ b/demo/sql.urp @@ -1,3 +1,4 @@ +debug database dbname=test sql sql.sql diff --git a/include/urweb.h b/include/urweb.h index 5a6c7178..6ac7df15 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -19,6 +19,8 @@ failure_kind uw_begin(uw_context, char *path); __attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *fmt, ...); char *uw_error_message(uw_context); +void uw_push_cleanup(uw_context, void (*func)(void *), void *arg); +void uw_pop_cleanup(uw_context); void *uw_malloc(uw_context, size_t); void uw_begin_region(uw_context); @@ -38,29 +40,28 @@ char *uw_Basis_htmlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_htmlifyString(uw_context, uw_Basis_string); char *uw_Basis_htmlifyBool(uw_context, uw_Basis_bool); -void uw_Basis_htmlifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_htmlifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_htmlifyString_w(uw_context, uw_Basis_string); -void uw_Basis_htmlifyBool_w(uw_context, uw_Basis_bool); +uw_unit uw_Basis_htmlifyInt_w(uw_context, uw_Basis_int); +uw_unit uw_Basis_htmlifyFloat_w(uw_context, uw_Basis_float); +uw_unit uw_Basis_htmlifyString_w(uw_context, uw_Basis_string); +uw_unit uw_Basis_htmlifyBool_w(uw_context, uw_Basis_bool); char *uw_Basis_attrifyInt(uw_context, uw_Basis_int); char *uw_Basis_attrifyFloat(uw_context, uw_Basis_float); char *uw_Basis_attrifyString(uw_context, uw_Basis_string); -void uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_attrifyString_w(uw_context, uw_Basis_string); - +uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); +uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); +uw_unit uw_Basis_attrifyString_w(uw_context, uw_Basis_string); char *uw_Basis_urlifyInt(uw_context, uw_Basis_int); char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_urlifyString(uw_context, uw_Basis_string); char *uw_Basis_urlifyBool(uw_context, uw_Basis_bool); -void uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_urlifyString_w(uw_context, uw_Basis_string); -void uw_Basis_urlifyBool_w(uw_context, uw_Basis_bool); +uw_unit uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); +uw_unit uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); +uw_unit uw_Basis_urlifyString_w(uw_context, uw_Basis_string); +uw_unit uw_Basis_urlifyBool_w(uw_context, uw_Basis_bool); uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **); uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **); diff --git a/src/c/urweb.c b/src/c/urweb.c index d4fd1844..039ba119 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -15,6 +15,11 @@ typedef struct regions { struct regions *next; } regions; +typedef struct { + void (*func)(void*); + void *arg; +} cleanup; + struct uw_context { char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; @@ -26,6 +31,8 @@ struct uw_context { regions *regions; + cleanup *cleanup, *cleanup_front, *cleanup_back; + char error_message[ERROR_BUF_LEN]; }; @@ -46,6 +53,8 @@ uw_context uw_init(size_t page_len, size_t heap_len) { ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup_back = ctx->cleanup = malloc(0); + ctx->error_message[0] = 0; return ctx; @@ -63,6 +72,7 @@ void uw_free(uw_context ctx) { free(ctx->page); free(ctx->heap); free(ctx->inputs); + free(ctx->cleanup); free(ctx); } @@ -70,6 +80,7 @@ void uw_reset_keep_request(uw_context ctx) { ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup; ctx->error_message[0] = 0; } @@ -78,6 +89,7 @@ void uw_reset_keep_error_message(uw_context ctx) { ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup; } void uw_reset(uw_context ctx) { @@ -107,14 +119,46 @@ failure_kind uw_begin(uw_context ctx, char *path) { } __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); } +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 *= 2; + ctx->cleanup = realloc(ctx->cleanup, newLen); + 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; +} + +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; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7d74376e..26f6149e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -850,6 +850,8 @@ fun p_exp' par env (e, loc) = 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) {", @@ -906,7 +908,7 @@ fun p_exp' par env (e, loc) = string "}", newline, newline, - string "PQclear(res);", + string "uw_pop_cleanup(ctx);", newline, if wontLeakAnything then box [string "uw_end_region(ctx);", diff --git a/tests/aborter2.ur b/tests/aborter2.ur new file mode 100644 index 00000000..a7270ba1 --- /dev/null +++ b/tests/aborter2.ur @@ -0,0 +1,7 @@ +table t : { X : int } + +fun main () : transaction page = + v <- query (SELECT * FROM t) + (fn r (_ : int) => return (error Shot down!)) + 0; + return Result: {[v]} diff --git a/tests/aborter2.urp b/tests/aborter2.urp new file mode 100644 index 00000000..edc6c7da --- /dev/null +++ b/tests/aborter2.urp @@ -0,0 +1,5 @@ +debug +database dbname=aborter +sql aborter2.sql + +aborter2 -- cgit v1.2.3 From 5badaf182a69fc7d67f9ae2e5a0a8e5bf7edea36 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 26 Oct 2008 08:41:17 -0400 Subject: Avoid using libpq when unneeded --- src/cjr_print.sml | 15 ++++++++++++--- src/compiler.sig | 2 +- src/compiler.sml | 13 ++++++++++--- 3 files changed, 23 insertions(+), 7 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 26f6149e..e26293ab 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1341,6 +1341,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] + | DPreparedStatements [] => box [] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -2182,6 +2183,8 @@ fun p_file env (ds, ps) = end) sequences, string "}"] + + val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds in box [string "#include ", newline, @@ -2191,8 +2194,11 @@ fun p_file env (ds, ps) = newline, string "#include ", newline, - string "#include ", - newline, + if hasDb then + box [string "#include ", + newline] + else + box [], newline, string "#include \"", string (OS.Path.joinDirFile {dir = Config.includ, @@ -2222,7 +2228,10 @@ fun p_file env (ds, ps) = string "}", newline, newline, - validate, + if hasDb then + validate + else + box [], newline, if List.exists (fn (DDatabase _, _) => true | _ => false) ds then box [] diff --git a/src/compiler.sig b/src/compiler.sig index f0914d0f..0c95934a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -38,7 +38,7 @@ signature COMPILER = sig debug : bool } val compile : string -> unit - val compileC : {cname : string, oname : string, ename : string} -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string} -> unit type ('src, 'dst) phase type ('src, 'dst) transform diff --git a/src/compiler.sml b/src/compiler.sml index df4ee48d..5d48287b 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -506,13 +506,13 @@ val sqlify = { val toSqlify = transform sqlify "sqlify" o toMono_opt2 -fun compileC {cname, oname, ename} = +fun compileC {cname, oname, ename, libs} = let val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" val compile = "gcc -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname - val link = "gcc -Werror -O3 -lm -pthread -lpq " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename + val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -553,6 +553,13 @@ fun compile job = 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 + "-lpq" + else + "" in Print.fprint s (CjrPrint.p_file CjrEnv.empty file); TextIO.output1 (outf, #"\n"); @@ -569,7 +576,7 @@ fun compile job = TextIO.closeOut outf end; - compileC {cname = cname, oname = oname, ename = ename}; + compileC {cname = cname, oname = oname, ename = ename, libs = libs}; cleanup () end -- cgit v1.2.3 From 794a3ad4e4713e74d2118d8f24b09ef4d35bd34f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 27 Oct 2008 08:16:19 -0400 Subject: Switch exit(1) call to uw_error() --- CHANGELOG | 12 ++++++++++++ src/cjr_print.sml | 10 +++------- 2 files changed, 15 insertions(+), 7 deletions(-) create mode 100644 CHANGELOG (limited to 'src/cjr_print.sml') diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 00000000..6b62d606 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,12 @@ +======== +20081027 +======== + +- On missing inputs, print an error message, but don't exit the web server. + +======== +20081026 +======== + +- Change 'sed' call to work on OSX. +- Avoid including or linking libpq files on apps that don't use SQL. diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e26293ab..7c0fd73c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1845,15 +1845,11 @@ fun p_file env (ds, ps) = string (Int.toString n), string ");", newline, - string "if (request == NULL) {", + string "if (request == NULL)", newline, - box [string "printf(\"Missing input ", + box [string "uw_error(ctx, FATAL, \"Missing input ", string x, - string "\\n\");", - newline, - string "exit(1);"], - newline, - string "}", + string "\");"], newline, string "uw_input_", p_ident x, -- cgit v1.2.3 From bca91774855a83f677f1a53abd3081258dc3a95c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 14:57:15 -0400 Subject: Reading timestamps from SQL --- src/c/urweb.c | 28 +++++++++++++++++++++------- src/cjr_print.sml | 2 ++ tests/time.ur | 10 +++++++++- tests/time.urp | 2 ++ 4 files changed, 34 insertions(+), 8 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a160637..df3ce6e1 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -728,6 +728,7 @@ uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { } #define TIME_FMT "%x %X" +#define TIME_FMT_PG "%Y-%m-%d %T" uw_Basis_string uw_Basis_htmlifyTime(uw_context ctx, uw_Basis_time t) { size_t len; @@ -950,10 +951,10 @@ uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { } uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { - char *end = strchr(s, 0); + char *dot = strchr(s, '.'), *end = strchr(s, 0); struct tm stm; - if (strptime(s, TIME_FMT, &stm) == end) { + if ((dot ? (*dot = 0, strptime(s, TIME_FMT_PG, &stm)) : strptime(s, TIME_FMT, &stm)) == end) { uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); *r = mktime(&stm); return r; @@ -992,11 +993,24 @@ uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { } uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { - char *end = strchr(s, 0); + char *dot = strchr(s, '.'), *end = strchr(s, 0); struct tm stm = {}; - if (strptime(s, TIME_FMT, &stm) == end) - return mktime(&stm); - else - uw_error(ctx, FATAL, "Can't parse time: %s", s); + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm)) { + *dot = '.'; + return mktime(&stm); + } + else { + *dot = '.'; + uw_error(ctx, FATAL, "Can't parse time: %s", s); + } + } + else { + if (strptime(s, TIME_FMT, &stm) == end) + return mktime(&stm); + else + uw_error(ctx, FATAL, "Can't parse time: %s", s); + } } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7c0fd73c..01d71872 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -403,6 +403,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = else box [string "uw_Basis_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 ")"] | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ env tAll)]; string "ERROR") @@ -1395,6 +1396,7 @@ fun p_sqltype' env (tAll as (t, loc)) = | TFfi ("Basis", "float") => "float8" | TFfi ("Basis", "string") => "text" | TFfi ("Basis", "bool") => "bool" + | TFfi ("Basis", "time") => "timestamp" | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") diff --git a/tests/time.ur b/tests/time.ur index 7b8b93ef..f6093dd3 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -1,4 +1,12 @@ +table t : { Id : int, Time : time } + val now : time = readError "10/30/08 14:35:42" val later : time = readError "10/30/08 14:37:42" -fun main () = return {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} +fun main () = + xml <- queryX (SELECT * FROM t) + (fn r => {[r.T.Id]}: {[r.T.Time]}
); + return + {xml} + {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} + diff --git a/tests/time.urp b/tests/time.urp index f48698e9..bfa87a0a 100644 --- a/tests/time.urp +++ b/tests/time.urp @@ -1,3 +1,5 @@ debug +database dbname=time +sql time.sql time -- cgit v1.2.3 From 5421d219d4b51b4b8ef18524d5b7db5c4939c36d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 15:11:37 -0400 Subject: Marshaling time to SQL --- include/urweb.h | 1 + src/c/urweb.c | 51 ++++++++++++++++++++++++++++++++++++++++++++------- src/cjr_print.sml | 13 +++++-------- src/monoize.sml | 4 ++++ src/prepare.sml | 2 ++ tests/time.ur | 1 + 6 files changed, 57 insertions(+), 15 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/include/urweb.h b/include/urweb.h index 752c00d2..43a63324 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -77,6 +77,7 @@ uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float); uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); +uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); char *uw_Basis_ensqlBool(uw_Basis_bool); diff --git a/src/c/urweb.c b/src/c/urweb.c index df3ce6e1..f05b0b9d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -860,6 +860,21 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { return "TRUE"; } +char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { + size_t len; + char *r; + struct tm stm; + + if (localtime_r(&t, &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 ""; +} + char *uw_Basis_ensqlBool(uw_Basis_bool b) { static uw_Basis_int true = 1; static uw_Basis_int false = 0; @@ -954,13 +969,33 @@ uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { char *dot = strchr(s, '.'), *end = strchr(s, 0); struct tm stm; - if ((dot ? (*dot = 0, strptime(s, TIME_FMT_PG, &stm)) : strptime(s, TIME_FMT, &stm)) == end) { - uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); - *r = mktime(&stm); - return r; + 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 = mktime(&stm); + return r; + } + else { + *dot = '.'; + return NULL; + } + } + else { + if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else if (strptime(s, TIME_FMT, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + *r = mktime(&stm); + return r; + } + else + return NULL; } - else - return NULL; } uw_Basis_int uw_Basis_stringToInt_error(uw_context ctx, uw_Basis_string s) { @@ -1008,7 +1043,9 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { } } else { - if (strptime(s, TIME_FMT, &stm) == end) + if (strptime(s, TIME_FMT_PG, &stm) == end) + return mktime(&stm); + else if (strptime(s, TIME_FMT, &stm) == end) return mktime(&stm); else uw_error(ctx, FATAL, "Can't parse time: %s", s); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 01d71872..f1f4ef70 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -413,13 +413,15 @@ datatype sql_type = | Float | String | Bool + | Time fun p_sql_type t = string (case t of Int => "uw_Basis_int" | Float => "uw_Basis_float" | String => "uw_Basis_string" - | Bool => "uw_Basis_bool") + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time") fun getPargs (e, _) = case e of @@ -430,6 +432,7 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] + | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] | ECase (e, _, _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" @@ -440,13 +443,7 @@ fun p_ensql t e = | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] - -fun p_ensql_len t e = - case t of - Int => string "sizeof(uw_Basis_int)" - | Float => string "sizeof(uw_Basis_float)" - | String => box [string "strlen(", e, string ")"] - | Bool => string "sizeof(uw_Basis_bool)" + | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] fun notLeaky env allowHeapAllocated = let diff --git a/src/monoize.sml b/src/monoize.sml index 0557bb4c..d28b27e4 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1220,6 +1220,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, 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)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/prepare.sml b/src/prepare.sml index 6bf929f0..166f658b 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -45,6 +45,8 @@ fun prepString (e, ss, n) = SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1) | EFfiApp ("Basis", "sqlifyBool", [e]) => SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyTime", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), (EPrim (Prim.String "TRUE"), _)), diff --git a/tests/time.ur b/tests/time.ur index f6093dd3..f66004a5 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -4,6 +4,7 @@ val now : time = readError "10/30/08 14:35:42" val later : time = readError "10/30/08 14:37:42" fun main () = + dml (INSERT INTO t (Id, Time) VALUES (42, {now})); xml <- queryX (SELECT * FROM t) (fn r => {[r.T.Id]}: {[r.T.Time]}
); return -- cgit v1.2.3 From 9f6397d0f801f6e020aa6123f14ddc44e11deee7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 12:08:41 -0500 Subject: Reading cookies works --- include/urweb.h | 2 + src/c/urweb.c | 16 ++ src/cjr.sml | 1 + src/cjr_print.sml | 741 +++++++++++++++++++++++++++------------------------- src/cjrize.sml | 7 + src/mono.sml | 2 + src/mono_print.sml | 3 + src/mono_reduce.sml | 2 + src/mono_util.sml | 6 + src/monoize.sml | 4 +- src/prepare.sml | 7 + tests/cookie.ur | 2 +- 12 files changed, 440 insertions(+), 353 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/include/urweb.h b/include/urweb.h index 4fb2d612..2330a0b4 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -100,4 +100,6 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); void uw_write_header(uw_context, uw_Basis_string); + +uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string); uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string); diff --git a/src/c/urweb.c b/src/c/urweb.c index dc58576a..be12c5ea 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1143,7 +1143,23 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { return NULL; } } +} + +uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { + int len = strlen(c); + char *s = ctx->headers, *p; + while (p = strchr(s, ':')) { + if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len) + && p + 2 + len < ctx->headers_end && p[2 + len] == '=') { + return p + 3 + len; + } else { + if ((s = strchr(p, 0)) && s < ctx->headers_end) + s += 2; + else + return NULL; + } + } } uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) { diff --git a/src/cjr.sml b/src/cjr.sml index dc700a56..84aea54e 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -92,6 +92,7 @@ datatype exp' = prepared : int option } | ENextval of { seq : exp, prepared : int option } + | EUnurlify of exp * typ withtype exp = exp' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f1f4ef70..06154b91 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -62,6 +62,12 @@ val ident = String.translate (fn #"'" => "PRIME" val p_ident = string o ident +fun isUnboxable (t : typ) = + case #1 t of + TDatatype (Default, _, _) => true + | TFfi ("Basis", "string") => true + | _ => false + fun p_typ' par env (t, loc) = case t of TFun (t1, t2) => parenIf par (box [p_typ' true env t2, @@ -96,11 +102,11 @@ fun p_typ' par env (t, loc) = handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n)) | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | TOption t => - (case #1 t of - TDatatype _ => p_typ' par env t - | TFfi ("Basis", "string") => p_typ' par env t - | _ => box [p_typ' par env t, - string "*"]) + if isUnboxable t then + p_typ' par env t + else + box [p_typ' par env t, + string "*"] and p_typ env = p_typ' false env @@ -228,13 +234,12 @@ fun p_pat (env, exit, depth) (p, _) = string "->data.", string x] | Option => - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -335,13 +340,12 @@ fun p_pat (env, exit, depth) (p, _) = space, string "=", space, - case #1 t of - TDatatype _ => box [string "disc", - string (Int.toString depth)] - | TFfi ("Basis", "string") => box [string "disc", - string (Int.toString depth)] - | _ => box [string "*disc", - string (Int.toString depth)], + if isUnboxable t then + box [string "disc", + string (Int.toString depth)] + else + box [string "*disc", + string (Int.toString depth)], string ";", newline, p, @@ -468,6 +472,288 @@ fun notLeaky env allowHeapAllocated = nl end +fun capitalize s = + if s = "" then + "" + else + str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + +fun unurlify env (t, loc) = + let + fun unurlify' rf t = + case t of + TFfi ("Basis", "unit") => string ("uw_unit_v") + | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + + | TRecord 0 => string "uw_unit_v" + | 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' rf (#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 ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), + space, + string ":", + space, + doEm rest, + string ")"] + in + doEm xncs + end + + | TDatatype (Option, i, xncs) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + 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 rf = IS.add (rf, i) + in + box [string "({", + space, + p_typ env t, + space, + string "*unurlify_", + string (Int.toString i), + string "(void) {", + 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 isUnboxable t then + unurlify' rf (#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' rf (#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, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | TDatatype (Default, i, _) => + if IS.member (rf, i) then + box [string "unurlify_", + string (Int.toString i), + string "()"] + else + let + val (x, xncs) = E.lookupDatatype env i + + val rf = IS.add (rf, 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' rf t, + string ";", + newline], + string "tmp;", + newline, + string "})", + space, + string ":", + space, + doEm rest, + string ")"] + in + box [string "({", + space, + p_typ env (t, ErrorMsg.dummySpan), + space, + string "unurlify_", + string (Int.toString i), + string "(void) {", + newline, + box [string "return", + space, + doEm xncs, + string ";", + newline], + string "}", + newline, + newline, + + string "unurlify_", + string (Int.toString i), + string "();", + newline, + string "})"] + end + + | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; + space) + in + unurlify' IS.empty t + end + fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t_GCC p @@ -485,30 +771,30 @@ fun p_exp' par env (e, loc) = NONE => raise Fail "CjrPrint: ECon argument status mismatch" | SOME t => t in - case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => 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 "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"] + if isUnboxable t then + p_exp' par 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 "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] end | ECon (Default, pc, eo) => let @@ -551,30 +837,30 @@ fun p_exp' par env (e, loc) = end | ENone _ => string "NULL" | ESome (t, e) => - (case #1 t of - TDatatype _ => p_exp' par env e - | TFfi ("Basis", "string") => p_exp' par env e - | _ => 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 "=", - p_exp' par env e, - string ";", - newline, - string "tmp;", - newline, - string "})"]) + if isUnboxable t then + p_exp' par 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 "=", + p_exp' par env e, + string ";", + newline, + string "tmp;", + newline, + string "})"] | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x] | EError (e, t) => @@ -1078,6 +1364,41 @@ fun p_exp' par env (e, loc) = string "}))"] end + | EUnurlify (e, t) => + let + fun getIt () = + if isUnboxable t then + unurlify 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 env t, + string ";", + newline, + string "tmp;", + newline, + string "})"] + in + box [string "({", + newline, + string "uw_Basis_string request = ", + p_exp env e, + string ";", + newline, + newline, + string "(request ? ", + getIt (), + string " : NULL);", + newline, + string "})"] + end + and p_exp env = p_exp' false env fun p_fun env (fx, n, args, ran, e) = @@ -1527,288 +1848,6 @@ fun p_file env (ds, ps) = string "}"] end - fun capitalize s = - if s = "" then - "" - else - str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) - - fun unurlify (t, loc) = - let - fun unurlify' rf t = - case t of - TFfi ("Basis", "unit") => string ("uw_unit_v") - | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") - - | TRecord 0 => string "uw_unit_v" - | 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' rf (#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 ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), - space, - string ":", - space, - doEm rest, - string ")"] - in - doEm xncs - end - - | TDatatype (Option, i, xncs) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - 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 rf = IS.add (rf, i) - in - box [string "({", - space, - p_typ env t, - space, - string "*unurlify_", - string (Int.toString i), - string "(void) {", - 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, - - case #1 t of - TDatatype _ => unurlify' rf (#1 t) - | TFfi ("Basis", "string") => unurlify' rf (#1 t) - | _ => 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' rf (#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, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | TDatatype (Default, i, _) => - if IS.member (rf, i) then - box [string "unurlify_", - string (Int.toString i), - string "()"] - else - let - val (x, xncs) = E.lookupDatatype env i - - val rf = IS.add (rf, 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' rf t, - string ";", - newline], - string "tmp;", - newline, - string "})", - space, - string ":", - space, - doEm rest, - string ")"] - in - box [string "({", - space, - p_typ env (t, ErrorMsg.dummySpan), - space, - string "unurlify_", - string (Int.toString i), - string "(void) {", - newline, - box [string "return", - space, - doEm xncs, - string ";", - newline], - string "}", - newline, - newline, - - string "unurlify_", - string (Int.toString i), - string "();", - newline, - string "})"] - end - - | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; - space) - in - unurlify' IS.empty t - end - fun p_page (ek, s, n, ts) = let val (ts, defInputs, inputsVar) = @@ -1855,7 +1894,7 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify t, + unurlify env t, string ";", newline] end) xts), @@ -1904,7 +1943,7 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify t, + unurlify env t, string ";", newline]) ts), defInputs, diff --git a/src/cjrize.sml b/src/cjrize.sml index db2bd48f..6c34923b 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -412,6 +412,13 @@ fun cifyExp (eAll as (e, loc), sm) = ((L'.ENextval {seq = e, prepared = NONE}, loc), sm) end + | L.EUnurlify (e, t) => + let + val (e, sm) = cifyExp (e, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EUnurlify (e, t), loc), sm) + end fun cifyDecl ((d, loc), sm) = case d of diff --git a/src/mono.sml b/src/mono.sml index b7ac6346..f465d2bd 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -94,6 +94,8 @@ datatype exp' = | EDml of exp | ENextval of exp + | EUnurlify of exp * typ + withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index 5d9f8007..8d91d048 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -272,6 +272,9 @@ fun p_exp' par env (e, _) = | ENextval e => box [string "nextval(", p_exp env e, string ")"] + | EUnurlify (e, _) => box [string "unurlify(", + p_exp env e, + string ")"] and p_exp env = p_exp' false env diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 7420f14f..3c4ac0df 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -41,6 +41,7 @@ fun impure (e, _) = | EQuery _ => true | EDml _ => true | ENextval _ => true + | EUnurlify _ => true | EAbs _ => false | EPrim _ => false @@ -275,6 +276,7 @@ fun summarize d (e, _) = | EDml e => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e fun exp env e = let diff --git a/src/mono_util.sml b/src/mono_util.sml index 080c3dc9..14ab1674 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -305,6 +305,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ENextval e', loc)) + | EUnurlify (e, t) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => + (EUnurlify (e', t'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 64522a18..b8c3a6a9 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -955,7 +955,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), (L'.EAbs ("_", un, s, - (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc), + (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc), + t), + loc)), loc)), loc), fm) end diff --git a/src/prepare.sml b/src/prepare.sml index 166f658b..6d63ad7d 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -191,6 +191,13 @@ fun prepExp (e as (_, loc), sns) = ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) end + | EUnurlify (e, t) => + let + val (e, sns) = prepExp (e, sns) + in + ((EUnurlify (e, t), loc), sns) + end + fun prepDecl (d as (_, loc), sns) = case #1 d of DStruct _ => (d, sns) diff --git a/tests/cookie.ur b/tests/cookie.ur index 36734260..cb4f8854 100644 --- a/tests/cookie.ur +++ b/tests/cookie.ur @@ -2,7 +2,7 @@ cookie c : string fun main () : transaction page = setCookie c "Hi"; - so <- requestHeader "Cookie"; + so <- getCookie c; case so of None => return No cookie | Some s => return Cookie: {[s]} -- cgit v1.2.3 From 0a10b5b7d2bbdcbfec723176b2a31d6b4c6d34d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:37:38 -0500 Subject: Inserted a NULL value --- CHANGELOG | 9 +++++ include/urweb.h | 6 +++ lib/basis.urs | 5 +++ src/c/urweb.c | 35 ++++++++++++++++++ src/cjr_print.sml | 101 +++++++++++++++++++++++++++++++++++++++++---------- src/elab_env.sml | 31 ++++++++++++++-- src/elaborate.sml | 47 ++++++++++++++++-------- src/mono_opt.sml | 5 +++ src/monoize.sml | 24 ++++++++++-- src/urweb.grm | 5 ++- src/urweb.lex | 1 + tests/sql_option.ur | 22 +++++++++++ tests/sql_option.urp | 5 +++ 13 files changed, 252 insertions(+), 44 deletions(-) create mode 100644 tests/sql_option.ur create mode 100644 tests/sql_option.urp (limited to 'src/cjr_print.sml') diff --git a/CHANGELOG b/CHANGELOG index aca01ea7..0f8d0f09 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +NEXT +======== + +- Nested function definitions +- Primitive "time" type +- Nullable SQL columns (via "option") +- Cookies + ======== 20081028 ======== diff --git a/include/urweb.h b/include/urweb.h index 7db66ed4..7e16fd40 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool); uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time); +uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*); +uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*); +uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*); +uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*); + char *uw_Basis_ensqlBool(uw_Basis_bool); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); diff --git a/lib/basis.urs b/lib/basis.urs index 84fb4e4c..f68bedee 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -188,6 +188,11 @@ val sql_int : sql_injectable int val sql_float : sql_injectable float val sql_string : sql_injectable string val sql_time : sql_injectable time +val sql_option_bool : sql_injectable (option bool) +val sql_option_int : sql_injectable (option int) +val sql_option_float : sql_injectable (option float) +val sql_option_string : sql_injectable (option string) +val sql_option_time : sql_injectable (option time) val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t diff --git a/src/c/urweb.c b/src/c/urweb.c index 638fbb16..1530c138 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { 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_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { int len; char *r; @@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) { 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); +} + uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) { 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"; @@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { 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; @@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) { return ""; } +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; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06154b91..d7e426c3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -408,24 +408,61 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = box [string "uw_Basis_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 ")"] + | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL"; Print.eprefaces' [("Type", p_typ 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 ")"] + + | _ => + p_unsql wontLeakStrings env tAll + (box [string "PQgetvalue(res, i, ", + string (Int.toString i), + string ")"]) + datatype sql_type = Int | Float | String | Bool | Time + | Nullable of sql_type + +fun p_sql_type' t = + case t of + Int => "uw_Basis_int" + | Float => "uw_Basis_float" + | String => "uw_Basis_string" + | Bool => "uw_Basis_bool" + | Time => "uw_Basis_time" + | Nullable String => "uw_Basis_string" + | Nullable t => p_sql_type' t ^ "*" -fun p_sql_type t = - string (case t of - Int => "uw_Basis_int" - | Float => "uw_Basis_float" - | String => "uw_Basis_string" - | Bool => "uw_Basis_bool" - | Time => "uw_Basis_time") +fun p_sql_type t = string (p_sql_type' t) fun getPargs (e, _) = case e of @@ -448,6 +485,12 @@ fun p_ensql t e = | String => e | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"] + | Nullable String => e + | Nullable t => box [string "(", + e, + string " == NULL ? NULL : ", + p_ensql t (box [string "*", e]), + string ")"] fun notLeaky env allowHeapAllocated = let @@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) = space, string "=", space, - p_unsql wontLeakStrings env t - (box [string "PQgetvalue(res, i, ", - string (Int.toString i), - string ")"]), + p_getcol wontLeakStrings env t i, string ";", newline]) outputs, @@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] - | DPreparedStatements [] => box [] + | DPreparedStatements [] => + box [string "static void uw_db_prepare(uw_context ctx) {", + newline, + string "}"] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -1708,7 +1751,7 @@ datatype 'a search = | NotFound | Error -fun p_sqltype' env (tAll as (t, loc)) = +fun p_sqltype'' env (tAll as (t, loc)) = case t of TFfi ("Basis", "int") => "int8" | TFfi ("Basis", "float") => "float8" @@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) = Print.eprefaces' [("Type", p_typ 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 p_file env (ds, ps) = let val (pds, env) = ListUtil.foldlMap (fn (d, env) => @@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) = Char.toLower (ident x), "' AND atttypid = (SELECT oid FROM pg_type", " WHERE typname = '", - p_sqltype' env t, - "'))"]) xts), + p_sqltype_base' env t, + "') AND attnotnull = ", + if is_not_null t then + "TRUE" + else + "FALSE", + ")"]) xts), ")"] val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '", @@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) = box [string "uw_", string (CharVector.map Char.toLower x), space, - p_sqltype env t, - space, - string "NOT", - space, - string "NULL"]) xts, + p_sqltype env (t, ErrorMsg.dummySpan)]) xts, string ");", newline, newline] diff --git a/src/elab_env.sml b/src/elab_env.sml index b14cd06c..46f62727 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -150,12 +150,14 @@ datatype class_key = CkNamed of int | CkRel of int | CkProj of int * string list * string + | CkApp of class_key * class_key fun ck2s ck = case ck of CkNamed n => "Named(" ^ Int.toString n ^ ")" | CkRel n => "Rel(" ^ Int.toString n ^ ")" | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")" + | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")" fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")" @@ -176,6 +178,12 @@ fun compare x = join (Int.compare (m1, m2), fn () => join (joinL String.compare (ms1, ms2), fn () => String.compare (x1, x2))) + | (CkProj _, _) => LESS + | (_, CkProj _) => GREATER + + | (CkApp (f1, x1), CkApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) end structure KM = BinaryMapFn(KK) @@ -251,6 +259,7 @@ fun liftClassKey ck = CkNamed _ => ck | CkRel n => CkRel (n + 1) | CkProj _ => ck + | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2) fun pushCRel (env : env) x k = let @@ -411,6 +420,10 @@ fun class_key_in (c, _) = | CNamed n => SOME (CkNamed n) | CModProj x => SOME (CkProj x) | CUnif (_, _, _, ref (SOME c)) => class_key_in c + | CApp (c1, c2) => + (case (class_key_in c1, class_key_in c2) of + (SOME k1, SOME k2) => SOME (CkApp (k1, k2)) + | _ => NONE) | _ => NONE fun class_pair_in (c, _) = @@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c = end) | _ => c -fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = +fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = case c of CModProj (m1, ms, x) => (case IM.find (strs, m1) of @@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c = (case IM.find (cons, n) of NONE => c | SOME nx => CModProj (m1, ms', nx)) + | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), + (sgnS_con' arg (#1 c2), #2 c2)) | _ => c fun sgnS_sgn (str, (sgns, strs, cons)) sgn = @@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} = 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 => (CNamed n, #2 sgn) - | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn) + NONE => base + | SOME t => (TFun (t, base), #2 sgn) val k = (KType, #2 sgn) in - foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn)) + foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn)) t xs end) else diff --git a/src/elaborate.sml b/src/elaborate.sml index 3b70c623..a6edc0ed 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) = end | _ => (c, loc) -fun normClassConstraint envs (c, loc) = +fun normClassKey envs c = + let + val c = ElabOps.hnormCon envs c + in + case #1 c of + L'.CApp (c1, c2) => + let + val c1 = normClassKey envs c1 + val c2 = normClassKey envs c2 + in + (L'.CApp (c1, c2), #2 c) + end + | _ => c + end + +fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon (#1 envs) f - val (x, gs) = hnormCon envs x + val f = unmodCon env f + val x = normClassKey env x in - ((L'.CApp (f, x), loc), gs) + (L'.CApp (f, x), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c - | _ => ((c, loc), []) + | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c + | _ => (c, loc) val makeInstantiable = @@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) = checkKind env t' tk ktype; (t', gs) end - val (dom, gs2) = normClassConstraint (env, denv) t' - val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e + 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 @ enD gs2 @ gs3) + enD gs1 @ gs2) end | L.ECApp (e, c) => let @@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' val env' = E.pushERel env x c' val c' = makeInstantiable c' in - ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.EDValRec vis => let @@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushENamed env x c' - val (c', gs'') = normClassConstraint (env, denv) c' + val c' = normClassConstraint env c' in (unifyKinds ck ktype handle KUnify ue => strError env (NotType (ck, ue))); - ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs)) + ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs)) end | L.SgiStr (x, sgn) => @@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = val (e', et, gs2) = elabExp (env, denv) e val gs3 = checkCon (env, denv) e' et c' - val (c', gs4) = normClassConstraint (env, denv) c' + val c = normClassConstraint env c' val (env', n) = E.pushENamed env x c' val c' = makeInstantiable c' in (*prefaces "DVal" [("x", Print.PD.string x), ("c'", p_con env c')];*) - ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs)) + ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs)) end | L.DValRec vis => let @@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file = ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))])) | TypeClass (env, c, r, loc) => let - val c = ElabOps.hnormCon env c + val c = normClassKey env c in case E.resolveClass env c of SOME e => r := SOME e diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b22f053b..93cb888b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -268,6 +268,11 @@ fun exp e = | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => + EPrim (Prim.String "NULL") + | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => + EPrim (Prim.String (sqlifyInt n)) + | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) => EPrim (Prim.String (sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) => diff --git a/src/monoize.sml b/src/monoize.sml index c4c296bd..83da382b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfiApp ("Basis", "dml", [e]) => let val (e, fm) = monoExp (env, st, fm) e - val un = (L'.TRecord [], loc) in - ((L'.EAbs ("_", un, un, - (L'.EDml (liftExpInExp 0 e), loc)), loc), + ((L'.EDml (liftExpInExp 0 e), loc), fm) end @@ -1274,6 +1272,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), fm) + | L.EFfi ("Basis", "sql_option_int") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_float") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_bool") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_string") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc), + fm) + | L.EFfi ("Basis", "sql_option_time") => + ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc), + (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc), + fm) | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) => ((L'.ERecord [], loc), fm) diff --git a/src/urweb.grm b/src/urweb.grm index b2f2d486..2482be1b 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -1251,6 +1251,9 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) + | NULL (sql_inject ((EVar (["Basis"], "None", Infer), + s (NULLleft, NULLright)))) + | COUNT LPAREN STAR RPAREN (let val loc = s (COUNTleft, RPARENright) in diff --git a/src/urweb.lex b/src/urweb.lex index f5ea558a..f4ae3a85 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -357,6 +357,7 @@ notags = [^<{\n]+; "UPDATE" => (Tokens.UPDATE (pos yypos, pos yypos + size yytext)); "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); + "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); diff --git a/tests/sql_option.ur b/tests/sql_option.ur new file mode 100644 index 00000000..257f8c55 --- /dev/null +++ b/tests/sql_option.ur @@ -0,0 +1,22 @@ +table t : { O : option int } + +fun addNull () = + dml (INSERT INTO t (O) VALUES (NULL)); + return Done + +(*fun add42 () = + dml (INSERT INTO t (O) VALUES (42)); + return Done*) + +fun main () : transaction page = + xml <- queryX (SELECT * FROM t) + (fn r => case r.T.O of + None => Nada
 + | Some n => Num: {[n]}
); + return + {xml} + + Add a null
+ + +(* Add a 42
*) diff --git a/tests/sql_option.urp b/tests/sql_option.urp new file mode 100644 index 00000000..543c32a8 --- /dev/null +++ b/tests/sql_option.urp @@ -0,0 +1,5 @@ +debug +database dbname=option +sql option.sql + +sql_option -- cgit v1.2.3 From 49f721d39e46ab0635cc2e9a5ed2a66944586640 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 15:52:13 -0500 Subject: Ensql'ing nullables --- src/cjr_print.sml | 7 +++++++ src/monoize.sml | 2 +- src/prepare.sml | 12 ++++++++++++ tests/sql_option.ur | 16 +++++++++++----- tests/sql_option.urs | 1 + 5 files changed, 32 insertions(+), 6 deletions(-) create mode 100644 tests/sql_option.urs (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index d7e426c3..b6c32e24 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -474,6 +474,13 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] + + | EFfiApp ("Basis", "sqlifyIntN", [e]) => [(e, Nullable Int)] + | EFfiApp ("Basis", "sqlifyFloatN", [e]) => [(e, Nullable Float)] + | EFfiApp ("Basis", "sqlifyStringN", [e]) => [(e, Nullable String)] + | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)] + | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)] + | ECase (e, _, _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" diff --git a/src/monoize.sml b/src/monoize.sml index 83da382b..70f15867 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -983,7 +983,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml (liftExpInExp 0 e), loc), + ((L'.EDml e, loc), fm) end diff --git a/src/prepare.sml b/src/prepare.sml index 6d63ad7d..b20c7fec 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -47,6 +47,18 @@ fun prepString (e, ss, n) = SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) | EFfiApp ("Basis", "sqlifyTime", [e]) => SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) + + | EFfiApp ("Basis", "sqlifyIntN", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::int8" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyFloatN", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::float8" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyStringN", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::text" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyBoolN", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::bool" :: ss, n + 1) + | EFfiApp ("Basis", "sqlifyTimeN", [e]) => + SOME ("$" ^ Int.toString (n + 1) ^ "::timestamp" :: ss, n + 1) + | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), (EPrim (Prim.String "TRUE"), _)), diff --git a/tests/sql_option.ur b/tests/sql_option.ur index 257f8c55..0676c907 100644 --- a/tests/sql_option.ur +++ b/tests/sql_option.ur @@ -4,9 +4,13 @@ fun addNull () = dml (INSERT INTO t (O) VALUES (NULL)); return Done -(*fun add42 () = - dml (INSERT INTO t (O) VALUES (42)); - return Done*) +fun add3 () = + dml (INSERT INTO t (O) VALUES ({Some 3})); + return Done + +fun addN r = + dml (INSERT INTO t (O) VALUES ({Some (readError r.N)})); + return Done fun main () : transaction page = xml <- queryX (SELECT * FROM t) @@ -17,6 +21,8 @@ fun main () : transaction page = {xml} Add a null
+ Add a 3
+
+ Add +
- -(* Add a 42
*) diff --git a/tests/sql_option.urs b/tests/sql_option.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/sql_option.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From dd4d718ac9f0a9862ebef19beb568bbedcc85848 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 18:49:38 -0500 Subject: Tree demo works --- demo/treeFun.ur | 2 +- lib/basis.urs | 5 + lib/top.ur | 13 ++ lib/top.urs | 12 ++ src/c/urweb.c | 2 +- src/cjr_print.sml | 9 +- src/mono_reduce.sml | 440 +++++++++++++++++++++++++++++----------------------- src/monoize.sml | 19 +++ src/urweb.grm | 13 +- src/urweb.lex | 1 + 10 files changed, 316 insertions(+), 200 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/demo/treeFun.ur b/demo/treeFun.ur index 60633695..236f354c 100644 --- a/demo/treeFun.ur +++ b/demo/treeFun.ur @@ -18,7 +18,7 @@ functor Make(M : sig (root : option M.key) = let fun recurse (root : option key) = - queryX' (SELECT * FROM tab WHERE tab.{parent} = {root}) + queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]}) (fn r => children <- recurse (Some r.Tab.id); return diff --git a/lib/basis.urs b/lib/basis.urs index daefe954..656c5b91 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -197,6 +197,11 @@ val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable t -> t -> sql_exp tables agg exps t +val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps bool + con sql_unary :: Type -> Type -> Type val sql_not : sql_unary bool bool val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} diff --git a/lib/top.ur b/lib/top.ur index abc70e53..5d00282c 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -226,3 +226,16 @@ fun oneRow (tables ::: {{Type}}) (exps ::: {Type}) None => error Query returned no rows | Some r => r) +fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) + (t ::: Type) (_ : sql_injectable (option t)) + (e1 : sql_exp tables agg exps (option t)) + (e2 : sql_exp tables agg exps (option t)) = + (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]}) + +fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) + (t ::: Type) (inj : sql_injectable (option t)) + (e1 : sql_exp tables agg exps (option t)) + (e2 : option t) = + case e2 of + None => (SQL {[e1]} IS NULL) + | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) diff --git a/lib/top.urs b/lib/top.urs index 6653db07..d6315b92 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -169,3 +169,15 @@ val oneRow : tables ::: {{Type}} -> exps ::: {Type} [[nm] ~ acc] => [nm = $fields] ++ acc) [] tables) + +val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type -> sql_injectable (option t) + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps (option t) + -> sql_exp tables agg exps bool + +val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> t ::: Type -> sql_injectable (option t) + -> sql_exp tables agg exps (option t) + -> option t + -> sql_exp tables agg exps bool diff --git a/src/c/urweb.c b/src/c/urweb.c index 1530c138..e50d6965 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -174,7 +174,7 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { newLen = 1; else newLen = len * 2; - ctx->cleanup = realloc(ctx->cleanup, newLen); + ctx->cleanup = realloc(ctx->cleanup, newLen * sizeof(cleanup)); ctx->cleanup_front = ctx->cleanup + len; ctx->cleanup_back = ctx->cleanup + newLen; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b6c32e24..2485e317 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -70,13 +70,14 @@ fun isUnboxable (t : typ) = fun p_typ' par env (t, loc) = case t of - TFun (t1, t2) => parenIf par (box [p_typ' true env t2, + TFun (t1, t2) => parenIf par (box [string "(", + p_typ' true env t2, space, string "(*)", space, string "(", p_typ env t1, - string ")"]) + string "))"]) | TRecord i => box [string "struct", space, string "__uws_", @@ -1151,6 +1152,10 @@ fun p_exp' par env (e, loc) = p_exp env initial, string ";", newline, + case prepared of + NONE => box [string "printf(\"Executing: %s\\n\", query);", + newline] + | _ => box [], string "PGresult *res = ", case prepared of NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index bf68f175..dce6ef35 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -34,6 +34,8 @@ open Mono structure E = MonoEnv structure U = MonoUtil +structure IM = IntBinaryMap + fun impure (e, _) = case e of @@ -212,6 +214,8 @@ fun p_event e = | Unsure => string "Unsure" end +val p_events = Print.p_list p_event + fun patBinds (p, _) = case p of PWild => 0 @@ -223,218 +227,266 @@ fun patBinds (p, _) = | PNone _ => 0 | PSome (_, p) => patBinds p -fun summarize d (e, _) = - case e of - EPrim _ => [] - | ERel n => if n >= d then [UseRel (n - d)] else [] - | ENamed _ => [] - | ECon (_, _, NONE) => [] - | ECon (_, _, SOME e) => summarize d e - | ENone _ => [] - | ESome (_, e) => summarize d e - | EFfi _ => [] - | EFfiApp ("Basis", "set_cookie", _) => [Unsure] - | EFfiApp (_, _, es) => List.concat (map (summarize d) es) - | EApp ((EFfi _, _), e) => summarize d e - | EApp _ => [Unsure] - | 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 (d + patBinds p) e) pes - in - case lss of - [] => raise Fail "Empty pattern match" - | ls :: lss => - if List.all (fn ls' => ls' = ls) lss then - summarize d e @ ls - else - [Unsure] - end - | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 - - | EError (e, _) => summarize d e @ [Unsure] - - | EWrite e => summarize d e @ [WritePage] - - | ESeq (e1, e2) => summarize d e1 @ summarize d e2 - | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 - - | EClosure (_, es) => List.concat (map (summarize d) es) - - | EQuery {query, body, initial, ...} => - List.concat [summarize d query, - summarize (d + 2) body, - summarize d initial, - [ReadDb]] - - | EDml e => summarize d e @ [WriteDb] - | ENextval e => summarize d e @ [WriteDb] - | EUnurlify (e, _) => summarize d e - -fun exp env e = +fun reduce file = let - (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) - - val r = + fun countAbs (e, _) = + case e of + EAbs (_, _, _, e) => 1 + countAbs e + | _ => 0 + + val absCounts = + foldl (fn ((d, _), absCounts) => + case d of + DVal (_, n, _, e, _) => + IM.insert (absCounts, n, countAbs e) + | DValRec vis => + foldl (fn ((_, n, _, e, _), absCounts) => + IM.insert (absCounts, n, countAbs e)) + absCounts vis + | _ => absCounts) + IM.empty file + + fun summarize d (e, _) = 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 e2 then - #1 (reduceExp env (ELet (x, t, e2, e1), loc)) - else - #1 (reduceExp env (subExpInExp (0, e2) e1))) - - | ECase (e', pes, {disc, result}) => + EPrim _ => [] + | ERel n => if n >= d then [UseRel (n - d)] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", _) => [Unsure] + | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => let - fun push () = - case result of - (TFun (dom, result), loc) => - if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then - EAbs ("_", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | _ => raise Fail "MonoReduce ECase") pes, - {disc = disc, result = result}), loc)) - else - e - | _ => e - - fun search pes = - case pes of - [] => push () - | (p, body) :: pes => - case match (env, p, e') of - No => search pes - | Maybe => push () - | Yes env => #1 (reduceExp env body) + fun unravel (e, ls) = + case e of + ENamed n => + let + val ls = rev ls + in + case IM.find (absCounts, n) of + NONE => [Unsure] + | SOME len => + if length ls < len then + ls + else + [Unsure] + end + | ERel n => List.revAppend (ls, [UseRel (n - d), Unsure]) + | EApp (f, x) => + unravel (#1 f, summarize d x @ ls) + | _ => [Unsure] in - search pes + unravel (e, []) end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EAbs _ => [] + + | EUnop (_, e) => summarize d e + | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 - | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => + | ERecord xets => List.concat (map (summarize d o #2) xets) + | EField (e, _) => summarize d e + + | ECase (e, pes, _) => let - val e' = (ELet (x2, t2, e1, - (ELet (x1, t1, b1, - liftExpInExp 1 b2), loc)), loc) + val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes in - (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), - ("e'", MonoPrint.p_exp env e')];*) - #1 (reduceExp env e') + case lss of + [] => raise Fail "Empty pattern match" + | ls :: lss => + if List.all (fn ls' => ls' = ls) lss then + summarize d e @ ls + else + [Unsure] 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', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => - (*if impure e' then - e - else*) - (* Seems unsound in general without the check... should revisit later *) - EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) - - | ELet (x, t, e', b) => - let - fun doSub () = - #1 (reduceExp env (subExpInExp (0, e') b)) - - fun trySub () = - case t of - (TFfi ("Basis", "string"), _) => doSub () - | _ => - case e' of - (ECase _, _) => e - | _ => doSub () - in - if impure e' then + | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 + + | EError (e, _) => summarize d e @ [Unsure] + + | EWrite e => summarize d e @ [WritePage] + + | ESeq (e1, e2) => summarize d e1 @ summarize d e2 + | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 + + | EClosure (_, es) => List.concat (map (summarize d) es) + + | EQuery {query, body, initial, ...} => + List.concat [summarize d query, + summarize (d + 2) body, + summarize d initial, + [ReadDb]] + + | EDml e => summarize d e @ [WriteDb] + | ENextval e => summarize d e @ [WriteDb] + | EUnurlify (e, _) => summarize d e + + + fun exp env e = + let + (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + 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 e2 then + #1 (reduceExp env (ELet (x, t, e2, e1), loc)) + else + #1 (reduceExp env (subExpInExp (0, e2) e1))) + + | ECase (e', pes, {disc, result}) => let - val effs_e' = summarize 0 e' - val effs_b = summarize 0 b - - fun does eff = List.exists (fn eff' => eff' = eff) effs_e' - val writesPage = does WritePage - val readsDb = does ReadDb - val writesDb = does WriteDb - - fun verifyUnused eff = - case eff of - UseRel r => r <> 0 - | Unsure => false - | _ => true - - fun verifyCompatible effs = - case effs of - [] => false - | eff :: effs => - case eff of - Unsure => false - | UseRel r => - if r = 0 then - List.all verifyUnused effs - else - verifyCompatible effs - | WritePage => not writesPage andalso verifyCompatible effs - | ReadDb => not writesDb andalso verifyCompatible effs - | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + fun push () = + case result of + (TFun (dom, result), loc) => + if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then + EAbs ("_", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | _ => raise Fail "MonoReduce ECase") pes, + {disc = disc, result = result}), loc)) + else + e + | _ => e + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e') of + No => search pes + | Maybe => push () + | Yes env => #1 (reduceExp env body) 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 verifyCompatible effs_b then - trySub () - else - e + search pes end - else - trySub () - end - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EField ((ERecord xes, _), x) => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => #1 e + | NONE => e) - | _ => e - in - (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) - r - 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', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => + (*if impure e' then + e + else*) + (* Seems unsound in general without the check... should revisit later *) + EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) + + | ELet (x, t, e', b) => + let + fun doSub () = + #1 (reduceExp env (subExpInExp (0, e') b)) + + fun trySub () = + case t of + (TFfi ("Basis", "string"), _) => doSub () + | _ => + case e' of + (ECase _, _) => e + | _ => doSub () + in + if impure e' then + let + val effs_e' = summarize 0 e' + val effs_b = summarize 0 b + + (*val () = Print.prefaces "Try" + [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), + ("e'", p_events effs_e'), + ("b", 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 + + fun verifyUnused eff = + case eff of + UseRel r => r <> 0 + | _ => true + + fun verifyCompatible effs = + case effs of + [] => false + | eff :: effs => + case eff of + Unsure => false + | UseRel r => + if r = 0 then + List.all verifyUnused effs + else + verifyCompatible effs + | WritePage => not writesPage andalso verifyCompatible effs + | ReadDb => not writesDb andalso verifyCompatible effs + | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs + 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 verifyCompatible effs_b then + trySub () + else + e + end + else + trySub () + end + + | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => + EPrim (Prim.String (s1 ^ s2)) -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) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s + | _ => e + in + (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + r + end -and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env + 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) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s -fun decl env d = d + and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env -val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty + fun decl env d = d + in + U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file + end end diff --git a/src/monoize.sml b/src/monoize.sml index 70f15867..9e1a4d22 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1584,6 +1584,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_is_null"), _), _), + _), _), + _), _), + _), _)) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + fun sc s = (L'.EPrim (Prim.String s), loc) + in + ((L'.EAbs ("s", s, s, + strcat loc [sc "(", + (L'.ERel 0, loc), + sc " IS NULL)"]), loc), + fm) + end + | L.EFfiApp ("Basis", "nextval", [e]) => let val (e, fm) = monoExp (env, st, fm) e diff --git a/src/urweb.grm b/src/urweb.grm index 2482be1b..4ac14450 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -214,7 +214,7 @@ fun tagIn bt = | TRUE | FALSE | CAND | OR | NOT | COUNT | AVG | SUM | MIN | MAX | ASC | DESC - | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL + | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | CURRENT_TIMESTAMP | NE | LT | LE | GT | GE @@ -346,7 +346,7 @@ fun tagIn bt = %right COMMA %right OR %right CAND -%nonassoc EQ NE LT LE GT GE +%nonassoc EQ NE LT LE GT GE IS %right ARROW %right PLUSPLUS MINUSMINUS %left PLUS MINUS @@ -1236,6 +1236,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) + | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp LT sqlexp (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1247,6 +1249,13 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In | sqlexp OR sqlexp (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | NOT sqlexp (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright))) + | sqlexp IS NULL (let + val loc = s (sqlexpleft, NULLright) + in + (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc), + sqlexp), loc) + end) + | LBRACE eexp RBRACE (sql_inject (#1 eexp, s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) diff --git a/src/urweb.lex b/src/urweb.lex index f4ae3a85..642282ec 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -358,6 +358,7 @@ notags = [^<{\n]+; "SET" => (Tokens.SET (pos yypos, pos yypos + size yytext)); "DELETE" => (Tokens.DELETE (pos yypos, pos yypos + size yytext)); "NULL" => (Tokens.NULL (pos yypos, pos yypos + size yytext)); + "IS" => (Tokens.IS (pos yypos, pos yypos + size yytext)); "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext)); -- cgit v1.2.3 From 24b68e6d7408f50023272e765687eab777596363 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 19:43:48 -0500 Subject: Tree demo working (and other assorted regressions fixed) --- demo/crud.ur | 8 ++++---- demo/prose | 4 ++++ demo/refFun.ur | 8 ++++---- demo/sql.ur | 4 ++-- demo/tree.ur | 22 ++++++++++++++++++++-- demo/tree.urp | 2 +- demo/treeFun.ur | 2 +- lib/top.ur | 4 ++-- src/cjr_print.sml | 37 +++++++++++++++++++++++++++++++++++++ src/elab_env.sig | 1 + src/elab_env.sml | 3 +++ src/elaborate.sml | 16 +++++++++++----- src/monoize.sml | 16 ++++++++++++++++ src/urweb.grm | 6 +++--- 14 files changed, 109 insertions(+), 24 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/demo/crud.ur b/demo/crud.ur index ee6a95f6..a120cb2a 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -102,7 +102,7 @@ functor Make(M : sig [[nm] ~ rest] => fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols - ++ {Id = (SQL {id})})); + ++ {Id = (SQL {[id]})})); ls <- list (); return

Inserted with ID {[id]}.

@@ -122,7 +122,7 @@ functor Make(M : sig fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols) - tab (WHERE T.Id = {id})); + tab (WHERE T.Id = {[id]})); ls <- list (); return

Saved!

@@ -131,7 +131,7 @@ functor Make(M : sig and upd (id : int) = - fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id}); + fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {[id]}); case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of None => return Not found! | Some fs => return
@@ -150,7 +150,7 @@ functor Make(M : sig
and delete (id : int) = - dml (DELETE FROM tab WHERE Id = {id}); + dml (DELETE FROM tab WHERE Id = {[id]}); ls <- list (); return

The deed is done.

diff --git a/demo/prose b/demo/prose index fad98e26..11661211 100644 --- a/demo/prose +++ b/demo/prose @@ -132,6 +132,10 @@ metaform2.urp

This example showcases code reuse by applying the same functor as in the last example. The Metaform2 module mixes pages from the functor with some new pages of its own.

+tree.urp + +

Here we see how we can abstract over common patterns of SQL queries. In particular, since standard SQL does not help much with queries over trees, we write a function for traversing an SQL tree, building an HTML representation, based on a user-provided function for rendering individual rows.

+ crud1.urp

This example pulls together much of what we have seen so far. It involves a generic "admin interface" builder. That is, we have the Crud.Make functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.

diff --git a/demo/refFun.ur b/demo/refFun.ur index d648f31e..e523bac7 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -10,19 +10,19 @@ functor Make(M : sig fun new d = id <- nextval s; - dml (INSERT INTO t (Id, Data) VALUES ({id}, {d})); + dml (INSERT INTO t (Id, Data) VALUES ({[id]}, {[d]})); return id fun read r = - o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {r}); + o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {[r]}); return (case o of None => error You already deleted that ref! | Some r => r.T.Data) fun write r d = - dml (UPDATE t SET Data = {d} WHERE Id = {r}) + dml (UPDATE t SET Data = {[d]} WHERE Id = {[r]}) fun delete r = - dml (DELETE FROM t WHERE Id = {r}) + dml (DELETE FROM t WHERE Id = {[r]}) end diff --git a/demo/sql.ur b/demo/sql.ur index 43a69573..44ff478f 100644 --- a/demo/sql.ur +++ b/demo/sql.ur @@ -27,7 +27,7 @@ fun list () = and add r = dml (INSERT INTO t (A, B, C, D) - VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D})); + VALUES ({[readError r.A]}, {[readError r.B]}, {[r.C]}, {[r.D]})); xml <- list (); return

Row added.

@@ -37,7 +37,7 @@ and add r = and delete a = dml (DELETE FROM t - WHERE t.A = {a}); + WHERE t.A = {[a]}); xml <- list (); return

Row deleted.

diff --git a/demo/tree.ur b/demo/tree.ur index 06a30cf9..27e9aa21 100644 --- a/demo/tree.ur +++ b/demo/tree.ur @@ -1,3 +1,4 @@ +sequence s table t : { Id : int, Parent : option int, Nam : string } open TreeFun.Make(struct @@ -5,11 +6,28 @@ open TreeFun.Make(struct end) fun row r = - #{[r.Id]}: {[r.Nam]} + #{[r.Id]}: {[r.Nam]} [Delete] + +
+ Add child: +
-fun main () = +and main () = xml <- tree row None; return {xml} + +
+ Add a top-level node: +
+ +and add parent r = + id <- nextval s; + dml (INSERT INTO t (Id, Parent, Nam) VALUES ({[id]}, {[parent]}, {[r.Nam]})); + main () + +and del id = + dml (DELETE FROM t WHERE Id = {[id]}); + main () diff --git a/demo/tree.urp b/demo/tree.urp index 2270dd06..880a7ab4 100644 --- a/demo/tree.urp +++ b/demo/tree.urp @@ -1,5 +1,5 @@ debug -database dbname=tree +database dbname=test sql tree.sql treeFun diff --git a/demo/treeFun.ur b/demo/treeFun.ur index 236f354c..15fe60f5 100644 --- a/demo/treeFun.ur +++ b/demo/treeFun.ur @@ -18,7 +18,7 @@ functor Make(M : sig (root : option M.key) = let fun recurse (root : option key) = - queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]}) + queryX' (SELECT * FROM tab WHERE {eqNullable' (SQL tab.{parent}) root}) (fn r => children <- recurse (Some r.Tab.id); return diff --git a/lib/top.ur b/lib/top.ur index 5d00282c..76fe73c1 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -230,12 +230,12 @@ fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (_ : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : sql_exp tables agg exps (option t)) = - (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]}) + (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2}) fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type}) (t ::: Type) (inj : sql_injectable (option t)) (e1 : sql_exp tables agg exps (option t)) (e2 : option t) = case e2 of - None => (SQL {[e1]} IS NULL) + None => (SQL {e1} IS NULL) | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2485e317..3941fdd9 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -799,6 +799,43 @@ fun unurlify env (t, loc) = string "})"] end + | TOption t => + box [string "(request[0] == '/' ? ++request : request, ", + string "((!strncmp(request, \"None\", 4) ", + string "&& (request[4] == 0 || request[4] == '/')) ", + string "? (request += 4, NULL) ", + string ": ((!strncmp(request, \"Some\", 4) ", + string "&& request[4] == '/') ", + string "? (request += 5, ", + if isUnboxable t then + unurlify' rf (#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' rf (#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 diff --git a/src/elab_env.sig b/src/elab_env.sig index 90cf8153..926837e1 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -74,6 +74,7 @@ signature ELAB_ENV = sig 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 diff --git a/src/elab_env.sml b/src/elab_env.sml index 46f62727..05da56db 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -542,6 +542,9 @@ fun lookupENamed (env : env) n = 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 diff --git a/src/elaborate.sml b/src/elaborate.sml index f0beecdd..e84f5307 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2282,9 +2282,15 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = let val env = case #1 h of L'.SgiCon (x, n, k, c) => - E.pushCNamedAs env x n k (SOME c) + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k (SOME c) | L'.SgiConAbs (x, n, k) => - E.pushCNamedAs env x n k NONE + if E.checkENamed env n then + env + else + E.pushCNamedAs env x n k NONE | _ => env in seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t @@ -2391,12 +2397,12 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = fun good () = let - val env = E.sgiBinds env sgi2All + val env = E.sgiBinds env sgi1All val env = if n1 = n2 then env else - E.pushCNamedAs env x n1 k' - (SOME (L'.CNamed n2, loc)) + E.pushCNamedAs env x n2 k' + (SOME (L'.CNamed n1, loc)) in SOME (env, denv) end diff --git a/src/monoize.sml b/src/monoize.sml index 9e1a4d22..ee509f52 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -390,6 +390,22 @@ fun fooifyExp fk env = ((L'.EApp ((L'.ENamed n, loc), e), loc), fm) end + | L'.TOption t => + let + val (body, fm) = fooify fm ((L'.ERel 0, loc), t) + in + ((L'.ECase (e, + [((L'.PNone t, loc), + (L'.EPrim (Prim.String "None"), loc)), + + ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), + body), loc))], + {disc = tAll, + result = (L'.TFfi ("Basis", "string"), loc)}), loc), + fm) + end + | _ => (E.errorAt loc "Don't know how to encode attribute type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; (dummyExp, fm)) diff --git a/src/urweb.grm b/src/urweb.grm index 4ac14450..b49cd793 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1236,7 +1236,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In end end) - | LBRACE LBRACK eexp RBRACK RBRACE (eexp) + | LBRACE eexp RBRACE (eexp) | sqlexp EQ sqlexp (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) | sqlexp NE sqlexp (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right))) @@ -1256,8 +1256,8 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In sqlexp), loc) end) - | LBRACE eexp RBRACE (sql_inject (#1 eexp, - s (LBRACEleft, RBRACEright))) + | LBRACE LBRACK eexp RBRACK RBRACE (sql_inject (#1 eexp, + s (LBRACEleft, RBRACEright))) | LPAREN sqlexp RPAREN (sqlexp) | NULL (sql_inject ((EVar (["Basis"], "None", Infer), -- cgit v1.2.3 From 7d6eed032a2b129056ff264a91076cec68035a34 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 12:12:50 -0500 Subject: Handle EError returning a function; handle multiple cookies in one input header --- src/c/urweb.c | 18 +++++++++++++++--- src/cjr_print.sml | 13 +++++-------- 2 files changed, 20 insertions(+), 11 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index e8c75275..57584f53 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1193,9 +1193,21 @@ uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { } while (p = strchr(s, ':')) { - if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len) - && p + 2 + len < ctx->headers_end && p[2 + len] == '=') { - return p + 3 + len; + if (!strncasecmp(s, "Cookie: ", 8)) { + p += 2; + while (1) { + if (!strncmp(p, c, len) + && p + len < ctx->headers_end && p[len] == '=') + return p + 1 + len; + else if (p = strchr(p, ';')) + p += 2; + else if ((s = strchr(s, 0)) && s < ctx->headers_end) { + s += 2; + break; + } + else + return NULL; + } } else { if ((s = strchr(p, 0)) && s < ctx->headers_end) s += 2; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 3941fdd9..7c13fcb5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -70,14 +70,8 @@ fun isUnboxable (t : typ) = fun p_typ' par env (t, loc) = case t of - TFun (t1, t2) => parenIf par (box [string "(", - p_typ' true env t2, - space, - string "(*)", - space, - string "(", - p_typ env t1, - string "))"]) + TFun (t1, t2) => (EM.errorAt loc "Function type remains"; + string "") | TRecord i => box [string "struct", space, string "__uws_", @@ -967,6 +961,9 @@ fun p_exp' par env (e, loc) = string "tmp;", newline, string "})"] + | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => + p_exp env (EError (e, ran), loc) + | EFfiApp (m, x, es) => box [string "uw_", p_ident m, string "_", -- cgit v1.2.3 From a676c53ffcf88833514d12968ee5b6b28aa8cc8a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 18:19:47 -0500 Subject: Remove some allocation --- src/cjr_print.sml | 15 +++++++++------ src/mono_opt.sml | 30 +++++++++++++++++++++++++++++- src/mono_reduce.sig | 2 ++ src/prepare.sml | 33 ++++++++++++++++++++++++--------- 4 files changed, 64 insertions(+), 16 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7c13fcb5..b1eb04b3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1186,10 +1186,6 @@ fun p_exp' par env (e, loc) = p_exp env initial, string ";", newline, - case prepared of - NONE => box [string "printf(\"Executing: %s\\n\", query);", - newline] - | _ => box [], string "PGresult *res = ", case prepared of NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);" @@ -1371,8 +1367,15 @@ fun p_exp' par env (e, loc) = | ENextval {seq, prepared} => let - val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val query = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + val query = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + end in box [string "(uw_begin_region(ctx), ", string "({", diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 93cb888b..e350db1d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -319,12 +319,40 @@ fun exp e = 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)} + body = (optExp (EWrite e', loc), loc)}*) | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index 2495c7f9..a6b6cc81 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -33,4 +33,6 @@ signature MONO_REDUCE = sig val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + val impure : Mono.exp -> bool + end diff --git a/src/prepare.sml b/src/prepare.sml index b20c7fec..28c14639 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -176,13 +176,21 @@ fun prepExp (e as (_, loc), sns) = end | EQuery {exps, tables, rnum, state, query, body, initial, ...} => - (case prepString (query, [], 0) of - NONE => (e, sns) - | SOME (ss, n) => - ((EQuery {exps = exps, tables = tables, rnum = rnum, - state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns)}, loc), - ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))) + let + val (body, sns) = prepExp (body, sns) + in + case prepString (query, [], 0) of + NONE => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + sns) + | SOME (ss, n) => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) + end | EDml {dml, ...} => (case prepString (dml, [], 0) of @@ -193,8 +201,15 @@ fun prepExp (e as (_, loc), sns) = | ENextval {seq, ...} => let - val s = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val s = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s]), loc) + val s = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) + end in case prepString (s, [], 0) of NONE => (e, sns) -- cgit v1.2.3 From 16c1bacfe1116391bb7b9a459e7ad53930f2719b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 16:51:45 -0500 Subject: Fix demo regression --- src/cjr_print.sml | 7 ++++++- src/prepare.sml | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b1eb04b3..cb88ca84 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -476,7 +476,12 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)] | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)] - | ECase (e, _, _) => [(e, Bool)] + | 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" diff --git a/src/prepare.sml b/src/prepare.sml index 28c14639..708bcade 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -183,7 +183,7 @@ fun prepExp (e as (_, loc), sns) = NONE => ((EQuery {exps = exps, tables = tables, rnum = rnum, state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns)}, loc), + initial = initial, prepared = NONE}, loc), sns) | SOME (ss, n) => ((EQuery {exps = exps, tables = tables, rnum = rnum, -- cgit v1.2.3 From f3e4bff668d3be5fcc7a2f6d04b7d9efb8f10624 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 18:39:38 -0500 Subject: Handle nullary transaction pages; avoid marking up headers array when reading cookies --- src/cjr_print.sml | 4 ++-- src/tag.sml | 9 +++++---- 2 files changed, 7 insertions(+), 6 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index cb88ca84..1c750b33 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1481,9 +1481,9 @@ fun p_exp' par env (e, loc) = in box [string "({", newline, - string "uw_Basis_string request = ", + string "uw_Basis_string request = uw_Basis_strdup(ctx, ", p_exp env e, - string ";", + string ");", newline, newline, string "(request ? ", diff --git a/src/tag.sml b/src/tag.sml index b19a0544..715da9ed 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -184,6 +184,8 @@ fun tag file = 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) => @@ -197,15 +199,14 @@ fun tag file = val (fnam, t, _, tag) = E.lookupENamed env f val (args, result) = unravel t - val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - val (abs, t) = case args of [] => let - val body = (EWrite (ENamed f, loc), loc) + val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc) + val body = (EWrite app, loc) in - ((EAbs ("x", unit, unit, body), loc), + (body, (TFun (unit, unit), loc)) end | _ => -- cgit v1.2.3 From 887af944c67e3395679a750a205ef114234c61a0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 19:20:37 -0500 Subject: Add CutMulti --- include/urweb.h | 1 + src/c/urweb.c | 7 ++++++ src/cjr_print.sml | 2 +- src/core.sml | 1 + src/core_print.sml | 17 +++++++++++++ src/core_util.sml | 16 ++++++++++++- src/corify.sml | 2 ++ src/elab.sml | 1 + src/elab_print.sml | 18 ++++++++++++++ src/elab_util.sml | 9 +++++++ src/elaborate.sml | 67 +++++++++++++++++++++++++++++++++++++++++++++------- src/expl.sml | 1 + src/expl_print.sml | 17 +++++++++++++ src/expl_util.sml | 8 +++++++ src/explify.sml | 2 ++ src/monoize.sml | 1 + src/reduce.sml | 13 ++++++++++ src/source.sml | 1 + src/source_print.sml | 5 ++++ src/termination.sml | 6 +++++ src/urweb.grm | 5 ++-- src/urweb.lex | 1 + tests/cut.ur | 7 +++--- tests/cut.urp | 3 +++ 24 files changed, 195 insertions(+), 16 deletions(-) create mode 100644 tests/cut.urp (limited to 'src/cjr_print.sml') diff --git a/include/urweb.h b/include/urweb.h index d148654f..ad08c811 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -75,6 +75,7 @@ uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **); uw_Basis_string uw_Basis_strcat(uw_context, uw_Basis_string, uw_Basis_string); uw_Basis_string uw_Basis_strdup(uw_context, uw_Basis_string); +uw_Basis_string uw_Basis_maybe_strdup(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float); diff --git a/src/c/urweb.c b/src/c/urweb.c index a347dd45..253cda87 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -869,6 +869,13 @@ uw_Basis_string uw_Basis_strdup(uw_context ctx, uw_Basis_string s1) { return s; } +uw_Basis_string uw_Basis_maybe_strdup(uw_context ctx, uw_Basis_string s1) { + if (s1) + return uw_Basis_strdup(ctx, s1); + else + return NULL; +} + char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) { int len; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 1c750b33..8c3c3d86 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1481,7 +1481,7 @@ fun p_exp' par env (e, loc) = in box [string "({", newline, - string "uw_Basis_string request = uw_Basis_strdup(ctx, ", + string "uw_Basis_string request = uw_Basis_maybe_strdup(ctx, ", p_exp env e, string ");", newline, diff --git a/src/core.sml b/src/core.sml index 1a181a68..4623bb49 100644 --- a/src/core.sml +++ b/src/core.sml @@ -95,6 +95,7 @@ datatype exp' = | 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 } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/core_print.sml b/src/core_print.sml index f209b84f..53922936 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -325,6 +325,23 @@ fun p_exp' par env (e, _) = 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]) | EFold _ => string "fold" | ECase (e, pes, {disc, result}) => diff --git a/src/core_util.sml b/src/core_util.sml index 38004f74..71efe16e 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -444,10 +444,16 @@ fun compare ((e1, _), (e2, _)) = | (ECut (e1, c1, _), ECut (e2, c2, _)) => join (compare (e1, e2), - fn () => Con.compare (c1, c2)) + 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 + | (EFold _, EFold _) => EQUAL | (EFold _, _) => LESS | (_, EFold _) => GREATER @@ -588,6 +594,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = 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)))) | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/corify.sml b/src/corify.sml index fdb4e7b7..8bb1a925 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -590,6 +590,8 @@ fun corifyExp st (e, loc) = 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.EFold k => (L'.EFold (corifyKind k), loc) | L.ECase (e, pes, {disc, result}) => diff --git a/src/elab.sml b/src/elab.sml index d00d1f1a..d997b7ec 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -110,6 +110,7 @@ datatype exp' = | 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 } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/elab_print.sml b/src/elab_print.sml index 2afedef1..62b1ea02 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -359,6 +359,24 @@ fun p_exp' par env (e, _) = 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]) + | EFold _ => string "fold" | ECase (e, pes, _) => parenIf par (box [string "case", diff --git a/src/elab_util.sml b/src/elab_util.sml index 9c25ae86..6e2c76f6 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -338,6 +338,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = 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)))) + | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/elaborate.sml b/src/elaborate.sml index 70429c1b..e3d334eb 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1664,6 +1664,21 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc), gs1 @ enD gs2 @ enD gs3 @ enD gs4) 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 (loc, ktype_record) + + val gs3 = + checkCon (env, denv) e' et + (L'.TRecord (L'.CConcat (c', rest), loc), loc) + val gs4 = D.prove env denv (c', rest, loc) + in + ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc), + gs1 @ enD gs2 @ enD gs3 @ enD gs4) + end | L.EFold => let @@ -2694,6 +2709,33 @@ fun wildifyStr env (str, sgn) = (case #1 str of L.StrConst ds => let + 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 (SOME k)) => decompileKind k + | L'.KUnif _ => NONE + fun decompileCon env (c, loc) = case c of L'.CRel i => @@ -2741,7 +2783,7 @@ fun wildifyStr env (str, sgn) = let val (needed, constraints, neededV) = case sgi of - L'.SgiConAbs (x, _, _) => (SS.add (neededC, x), constraints, neededV) + L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, k), constraints, neededV) | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV) | L'.SgiVal (x, _, t) => @@ -2764,18 +2806,18 @@ fun wildifyStr env (str, sgn) = in (needed, constraints, neededV, E.sgiBinds env' (sgi, loc)) end) - (SS.empty, [], SS.empty, env) sgis + (SM.empty, [], SS.empty, env) sgis val (neededC, neededV) = foldl (fn ((d, _), needed as (neededC, neededV)) => case d of - L.DCon (x, _, _) => ((SS.delete (neededC, x), neededV) + L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) - | L.DClass (x, _) => ((SS.delete (neededC, x), neededV) + | L.DClass (x, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x)) handle NotFound => needed) - | L.DOpen _ => (SS.empty, SS.empty) + | L.DOpen _ => (SM.empty, SS.empty) | _ => needed) (neededC, neededV) ds @@ -2797,13 +2839,20 @@ fun wildifyStr env (str, sgn) = end val ds' = - case SS.listItems neededC of + case SM.listItemsi neededC of [] => ds' | xs => let - val kwild = (L.KWild, #2 str) - val cwild = (L.CWild kwild, #2 str) - val ds'' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs + val ds'' = 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 in ds'' @ ds' end diff --git a/src/expl.sml b/src/expl.sml index 57396684..cce0fc22 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -92,6 +92,7 @@ datatype exp' = | 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 } | EFold of kind | ECase of exp * (pat * exp) list * { disc : con, result : con } diff --git a/src/expl_print.sml b/src/expl_print.sml index e3153ef2..2ce0c5e2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -334,6 +334,23 @@ fun p_exp' par env (e, loc) = 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]) | EFold _ => string "fold" | EWrite e => box [string "write(", diff --git a/src/expl_util.sml b/src/expl_util.sml index 2bd9eabd..d2073a23 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -303,6 +303,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = 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)))) | EFold k => S.map2 (mfk k, fn k' => diff --git a/src/explify.sml b/src/explify.sml index 4115476b..e3c22f20 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -105,6 +105,8 @@ fun explifyExp (e, loc) = 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.EFold k => (L'.EFold (explifyKind k), loc) | L.ECase (e, pes, {disc, result}) => diff --git a/src/monoize.sml b/src/monoize.sml index a4f38dc6..28ea5946 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2014,6 +2014,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EConcat _ => poly () | L.ECut _ => poly () + | L.ECutMulti _ => poly () | L.EFold _ => poly () | L.ECase (e, pes, {disc, result}) => diff --git a/src/reduce.sml b/src/reduce.sml index 1404b598..e480dea2 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -133,6 +133,19 @@ fun exp env e = in #1 (reduceExp env (ERecord (fields (xts, [])), loc)) end + | ECutMulti (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) => + let + fun fields (remaining, passed) = + case remaining of + [] => [] + | (x, t) :: rest => + (x, + (EField (r, x, {field = t, + rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc), + t) :: fields (rest, (x, t) :: passed) + in + #1 (reduceExp env (ERecord (fields (xts, [])), loc)) + end | _ => e in diff --git a/src/source.sml b/src/source.sml index 2a348338..7685bb2f 100644 --- a/src/source.sml +++ b/src/source.sml @@ -123,6 +123,7 @@ datatype exp' = | EField of exp * con | EConcat of exp * exp | ECut of exp * con + | ECutMulti of exp * con | EFold | EWild diff --git a/src/source_print.sml b/src/source_print.sml index 3c26812f..77f2d749 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -268,6 +268,11 @@ fun p_exp' par (e, _) = string "--", space, p_con' true c]) + | ECutMulti (e, c) => parenIf par (box [p_exp' true e, + space, + string "---", + space, + p_con' true c]) | EFold => string "fold" | ECase (e, pes) => parenIf par (box [string "case", diff --git a/src/termination.sml b/src/termination.sml index 2db5bb11..e89f329e 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -265,6 +265,12 @@ fun declOk' env (d, loc) = 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 diff --git a/src/urweb.grm b/src/urweb.grm index 5241ed20..8a3bee7f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -197,7 +197,7 @@ fun tagIn bt = | DATATYPE | OF | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI - | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE + | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE @@ -348,7 +348,7 @@ fun tagIn bt = %right CAND %nonassoc EQ NE LT LE GT GE IS %right ARROW -%right PLUSPLUS MINUSMINUS +%right PLUSPLUS MINUSMINUS MINUSMINUSMINUS %left PLUS MINUS %left STAR DIVIDE MOD %left NOT @@ -692,6 +692,7 @@ eexp : eapps (eapps) end) | 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) diff --git a/src/urweb.lex b/src/urweb.lex index 642282ec..aef68ad1 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -251,6 +251,7 @@ notags = [^<{\n]+; "=>" => (Tokens.DARROW (pos yypos, pos yypos + size yytext)); "++" => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext)); "--" => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext)); + "---" => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext)); "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); diff --git a/tests/cut.ur b/tests/cut.ur index 6b7b4ef3..7d0ee77a 100644 --- a/tests/cut.ur +++ b/tests/cut.ur @@ -1,6 +1,7 @@ val r = {A = 1, B = "Hi", C = 0.0} val rA = r -- #A +val rB = r --- [A = _, C = _] -val main : unit -> page = fn () => - {cdata rA.B} - +fun main () : transaction page = return + {cdata rA.B}, {cdata rB.B} + diff --git a/tests/cut.urp b/tests/cut.urp new file mode 100644 index 00000000..5c9c3e81 --- /dev/null +++ b/tests/cut.urp @@ -0,0 +1,3 @@ +debug + +cut -- cgit v1.2.3 From ec745f90fc97e10948dc32ec4f44aabf5c6908db Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 16:19:26 -0500 Subject: Successfully generated a page element from a signal --- Makefile.in | 3 +++ jslib/urweb.js | 1 + src/c/driver.c | 5 ----- src/cjr.sml | 2 ++ src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++++++++++ src/cjrize.sml | 1 + src/config.sig | 1 + src/config.sml.in | 2 ++ src/jscomp.sml | 18 +++++++++++++----- src/mono.sml | 3 +++ src/mono_env.sml | 1 + src/mono_print.sml | 4 ++++ src/mono_shake.sml | 6 ++++-- src/mono_util.sml | 6 +++++- src/monoize.sml | 4 +++- src/prepare.sml | 1 + 17 files changed, 65 insertions(+), 14 deletions(-) create mode 100644 jslib/urweb.js (limited to 'src/cjr_print.sml') diff --git a/Makefile.in b/Makefile.in index 57a083bd..ed65ceea 100644 --- a/Makefile.in +++ b/Makefile.in @@ -5,6 +5,7 @@ SITELISP := @SITELISP@ LIB_UR := $(LIB)/ur LIB_C := $(LIB)/c +LIB_JS := $(LIB)/js all: smlnj mlton c @@ -70,6 +71,8 @@ install: cp lib/*.ur $(LIB_UR)/ mkdir -p $(LIB_C) cp clib/*.o $(LIB_C)/ + mkdir -p $(LIB_JS) + cp jslib/*.js $(LIB_JS)/ mkdir -p $(INCLUDE) cp include/*.h $(INCLUDE)/ mkdir -p $(SITELISP) diff --git a/jslib/urweb.js b/jslib/urweb.js new file mode 100644 index 00000000..32912e4c --- /dev/null +++ b/jslib/urweb.js @@ -0,0 +1 @@ +function sreturn(v) { return {v : v} } diff --git a/src/c/driver.c b/src/c/driver.c index a25cd743..34e57a6d 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -193,8 +193,6 @@ static void *worker(void *data) { uw_set_headers(ctx, headers); while (1) { - uw_write(ctx, ""); - if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); if (retries_left) @@ -211,13 +209,10 @@ static void *worker(void *data) { } uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); - uw_write_header(ctx, "Content-type: text/html\r\n"); strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { - uw_write(ctx, ""); - if (uw_db_commit(ctx)) { fk = FATAL; diff --git a/src/cjr.sml b/src/cjr.sml index 84aea54e..43a29a6c 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -109,6 +109,8 @@ datatype decl' = | DDatabase of string | DPreparedStatements of (string * int) list + | DJavaScript of string + withtype decl = decl' located type file = decl list * (Core.export_kind * string * int * typ list) list diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 49e86140..9921ee48 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -166,6 +166,7 @@ fun declBinds env (d, loc) = | DSequence _ => env | DDatabase _ => env | DPreparedStatements _ => env + | DJavaScript _ => env end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8c3c3d86..06f9f5ca 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1800,6 +1800,10 @@ fun p_decl env (dAll as (d, _) : decl) = string "}"] + | DJavaScript s => box [string "static char jslib[] = \"", + string (String.toString s), + string "\";"] + datatype 'a search = Found of 'a | NotFound @@ -2048,6 +2052,10 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, + string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline, box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2070,6 +2078,8 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, + string "uw_write(ctx, \"\");", + newline, string "return;", newline, string "}", @@ -2374,6 +2384,16 @@ fun p_file env (ds, ps) = newline, string "void uw_handle(uw_context ctx, char *request) {", newline, + string "if (!strcmp(request, \"/app.js\")) {", + newline, + box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, jslib);", + newline, + string "return;", + newline], + string "}", + newline, p_list_sep newline (fn x => x) pds', newline, string "uw_error(ctx, FATAL, \"Unknown page\");", diff --git a/src/cjrize.sml b/src/cjrize.sml index f3c5e5a7..78513ef7 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -528,6 +528,7 @@ fun cifyDecl ((d, loc), sm) = | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) + | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) fun cjrize ds = let diff --git a/src/config.sig b/src/config.sig index 6075482e..90fb72e7 100644 --- a/src/config.sig +++ b/src/config.sig @@ -6,6 +6,7 @@ signature CONFIG = sig val libUr : string val libC : string + val libJs : string val gccArgs : string end diff --git a/src/config.sml.in b/src/config.sml.in index 9e53986b..c7d231d5 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -9,6 +9,8 @@ val libUr = OS.Path.joinDirFile {dir = lib, file = "ur"} val libC = OS.Path.joinDirFile {dir = lib, file = "c"} +val libJs = OS.Path.joinDirFile {dir = lib, + file = "js"} val gccArgs = "@GCCARGS@" diff --git a/src/jscomp.sml b/src/jscomp.sml index b0842c6b..95c18016 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -285,7 +285,7 @@ fun jsExp mode outer = in (strcat [str "document.write(", e, - str ")"], st) + str ".v)"], st) end | ESeq (e1, e2) => @@ -317,9 +317,9 @@ fun jsExp mode outer = let val (e, st) = jsE inner (e, st) in - (strcat [(*str "sreturn(",*) - e(*, - str ")"*)], + (strcat [str "sreturn(", + e, + str ")"], st) end end @@ -369,8 +369,16 @@ fun process file = {decls = [], script = ""} file + + val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.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 [] in - ds + TextIO.closeIn inf; + (DJavaScript lines, ErrorMsg.dummySpan) :: ds end end diff --git a/src/mono.sml b/src/mono.sml index c6e0ae8a..1a7fde00 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -118,6 +118,9 @@ datatype decl' = | DSequence of string | DDatabase of string + | DJavaScript of string + + withtype decl = decl' located type file = decl list diff --git a/src/mono_env.sml b/src/mono_env.sml index cce4a4c4..248567de 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -110,6 +110,7 @@ fun declBinds env (d, loc) = | DTable _ => env | DSequence _ => env | DDatabase _ => env + | DJavaScript _ => env fun patBinds env (p, loc) = case p of diff --git a/src/mono_print.sml b/src/mono_print.sml index 89b6c35b..e44bb74c 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -379,6 +379,10 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DJavaScript s => box [string "JavaScript(", + string s, + string ")"] + fun p_file env file = let diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6714718a..34bd98be 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -56,7 +56,8 @@ fun shake file = | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc - | ((DDatabase _, _), acc) => acc) + | ((DDatabase _, _), acc) => acc + | ((DJavaScript _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -112,7 +113,8 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true - | (DDatabase _, _) => true) file + | (DDatabase _, _) => true + | (DJavaScript _, _) => true) file end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 553f802e..9788a551 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -323,6 +323,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EJavaScript (m, e'), loc)) + | ESignalReturn e => S.map2 (mfe ctx e, fn e' => @@ -421,6 +422,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll + | DJavaScript _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -501,6 +503,7 @@ fun mapfoldB (all as {bind, ...}) = | DTable _ => ctx | DSequence _ => ctx | DDatabase _ => ctx + | DJavaScript _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -548,7 +551,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count - | DDatabase _ => count) 0 + | DDatabase _ => count + | DJavaScript _ => count) 0 end diff --git a/src/monoize.sml b/src/monoize.sml index 1b7b467d..a0a0df30 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1844,7 +1844,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in case tag of "body" => normal ("body", NONE, - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EStrcat ((L'.EPrim (Prim.String ""), loc), + (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), + loc)), loc)) | "dyn" => (case #1 attrs of diff --git a/src/prepare.sml b/src/prepare.sml index 708bcade..110f6f9a 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -258,6 +258,7 @@ fun prepDecl (d as (_, loc), sns) = | DSequence _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) + | DJavaScript _ => (d, sns) fun prepare (ds, ps) = let -- cgit v1.2.3 From 0c5be5455c4f1e078831cb434bb9df215a410ad9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Jan 2009 10:22:19 -0500 Subject: Use header to set default script type --- src/c/urweb.c | 2 +- src/cjr_print.sml | 2 ++ src/monoize.sml | 4 ++-- 3 files changed, 5 insertions(+), 3 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 54646fd8..e28fa5f4 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -382,7 +382,7 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) { } else { char *r = uw_malloc(ctx, 41 + (ctx->script_front - ctx->script)); - sprintf(r, "", ctx->script); + sprintf(r, "", ctx->script); return r; } } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 06f9f5ca..f8b1f23b 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2054,6 +2054,8 @@ fun p_file env (ds, ps) = newline, string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", newline, + string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline, string "uw_write(ctx, \"\");", newline, box [string "{", diff --git a/src/monoize.sml b/src/monoize.sml index 4a2f47d7..56310c1b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1898,7 +1898,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = e), _), _)] => (e, fm) | [("Signal", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ""), loc)), loc)), loc), fm) @@ -1919,7 +1919,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = loc)), loc), fm) end | SOME (_, src, _) => - (strcat [str ""], fm)) -- cgit v1.2.3 From e27335a18e8f4b1cca2749e8d41863b3cbef9b62 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 15 Feb 2009 09:27:36 -0500 Subject: Export RPC functions and push RPC calls through to Mono --- src/cjr_print.sml | 2 ++ src/cjrize.sml | 2 ++ src/core.sml | 1 + src/core_print.sml | 1 + src/jscomp.sml | 4 ++++ src/mono.sml | 2 ++ src/mono_print.sml | 9 +++++++++ src/mono_reduce.sml | 3 +++ src/mono_util.sml | 7 +++++++ src/monoize.sml | 8 +++++++- src/rpcify.sml | 47 +++++++++++++++++++++++++++++++++++------------ 11 files changed, 73 insertions(+), 13 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f8b1f23b..8f5c8551 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1849,6 +1849,7 @@ fun p_file env (ds, ps) = val fields = foldl (fn ((ek, _, _, ts), fields) => case ek of Core.Link => fields + | Core.Rpc => fields | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) => @@ -1971,6 +1972,7 @@ fun p_file env (ds, ps) = val (ts, defInputs, inputsVar) = case ek of Core.Link => (List.take (ts, length ts - 1), string "", string "") + | Core.Rpc => (List.take (ts, length ts - 1), string "", string "") | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) => diff --git a/src/cjrize.sml b/src/cjrize.sml index 1a5d10c0..77674158 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -429,6 +429,8 @@ fun cifyExp (eAll as (e, loc), sm) = | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" + | L.EServerCall _ => raise Fail "Cjrize EServerCall" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) => diff --git a/src/core.sml b/src/core.sml index fbe150c1..62f046fe 100644 --- a/src/core.sml +++ b/src/core.sml @@ -113,6 +113,7 @@ withtype exp = exp' located datatype export_kind = Link | Action + | Rpc datatype decl' = DCon of string * int * kind * con diff --git a/src/core_print.sml b/src/core_print.sml index 64cead70..e9a36fbb 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -436,6 +436,7 @@ fun p_export_kind ck = case ck of Link => string "link" | Action => string "action" + | Rpc => string "rpc" fun p_datatype env (x, n, xs, cons) = let diff --git a/src/jscomp.sml b/src/jscomp.sml index f61ec3f0..627ba8f6 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -98,6 +98,7 @@ fun varDepth (e, _) = | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e + | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es) fun closedUpto d = let @@ -138,6 +139,7 @@ fun closedUpto d = | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e + | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek in cu 0 end @@ -809,6 +811,8 @@ fun process file = str ")"], st) end + + | EServerCall _ => raise Fail "Jscomp EServerCall" end in jsE diff --git a/src/mono.sml b/src/mono.sml index 8999704c..547f8a55 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -109,6 +109,8 @@ datatype exp' = | ESignalBind of exp * exp | ESignalSource of exp + | EServerCall of int * exp list * exp + withtype exp = exp' located datatype decl' = diff --git a/src/mono_print.sml b/src/mono_print.sml index 1e9de3d8..a859a1bd 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -308,6 +308,15 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] + | EServerCall (n, es, e) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] + and p_exp env = p_exp' false env fun p_vali env (x, n, t, e, s) = diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 878fec92..7d39648a 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -81,6 +81,7 @@ fun impure (e, _) = | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e + | EServerCall _ => true val liftExpInExp = Monoize.liftExpInExp @@ -344,6 +345,8 @@ fun reduce file = | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e + + | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), diff --git a/src/mono_util.sml b/src/mono_util.sml index 9ce3293b..13e0d32c 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -349,6 +349,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (ESignalSource e', loc)) + + | EServerCall (n, es, ek) => + S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es, + fn es' => + S.map2 (mfe ctx ek, + fn ek' => + (EServerCall (n, es', ek'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index a1f61143..fb1ac2f1 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2225,7 +2225,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall _ => raise Fail "Monoize EServerCall" + | L.EServerCall (n, es, ek) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + val (ek, fm) = monoExp (env, st, fm) ek + in + ((L'.EServerCall (n, es, ek), loc), fm) + end end fun monoDecl (env, fm) (all as (d, loc)) = diff --git a/src/rpcify.sml b/src/rpcify.sml index dec8dc18..09c44a7a 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -53,8 +53,11 @@ val csBasis = SS.addList (SS.empty, "alert"]) type state = { - exps : int IM.map, - decls : (string * int * con * exp * string) list + cpsed : int IM.map, + cps_decls : (string * int * con * exp * string) list, + + exported : IS.set, + export_decls : decl list } fun frob file = @@ -114,6 +117,19 @@ fun frob file = (0, [])) val (n, args) = getApp (trans1, []) + + val (exported, export_decls) = + if IS.member (#exported st, n) then + (#exported st, #export_decls st) + else + (IS.add (#exported st, n), + (DExport (Rpc, n), loc) :: #export_decls st) + + val st = {cpsed = #cpsed st, + cps_decls = #cps_decls st, + + exported = exported, + export_decls = export_decls} in (EServerCall (n, args, trans2), st) end @@ -128,19 +144,26 @@ fun frob file = decl = fn x => x} st d in - (case #decls st of - [] => [d] - | ds => - case d of - (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] - | (_, loc) => [(DValRec ds, loc), d], - {decls = [], - exps = #exps st}) + (List.revAppend (case #cps_decls st of + [] => [d] + | ds => + case d of + (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] + | (_, loc) => [d, (DValRec ds, loc)], + #export_decls st), + {cpsed = #cpsed st, + cps_decls = [], + + exported = #exported st, + export_decls = []}) end val (file, _) = ListUtil.foldlMapConcat decl - {decls = [], - exps = IM.empty} + {cpsed = IM.empty, + cps_decls = [], + + exported = IS.empty, + export_decls = []} file in file -- cgit v1.2.3 From 1557ac806159fe58eaa442527f73e569dd04f88e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 15 Feb 2009 10:32:50 -0500 Subject: First gimpy RPC --- lib/js/urweb.js | 29 +++++++++++++++++++++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 32 ++++++++++++++++++++++---------- src/cjrize.sml | 5 +++-- src/core.sml | 2 +- src/core_print.sml | 16 ++++++++-------- src/core_util.sml | 10 ++++++---- src/jscomp.sml | 14 +++++++++++--- src/mono.sml | 4 ++-- src/mono_print.sml | 46 +++++++++++++++++++++++++--------------------- src/mono_reduce.sml | 2 +- src/mono_shake.sml | 2 +- src/mono_util.sml | 16 ++++++++++------ src/monoize.sml | 38 ++++++++++++++++++++++++++++---------- src/pathcheck.sml | 2 +- src/reduce.sml | 2 +- src/reduce_local.sml | 2 +- src/rpcify.sml | 30 +++++++++++++++++++++++++++++- src/shake.sml | 2 +- tests/rpc.ur | 4 +++- tests/rpc.urp | 2 +- 21 files changed, 185 insertions(+), 77 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/lib/js/urweb.js b/lib/js/urweb.js index c46263b8..9dd4dbbe 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -111,3 +111,32 @@ function cr(n) { return closures[n](); } + +function getXHR() +{ + try { + return new XMLHttpRequest(); + } catch (e) { + try { + return new ActiveXObject("Msxml2.XMLHTTP"); + } catch (e) { + try { + return new ActiveXObject("Microsoft.XMLHTTP"); + } catch (e) { + throw "Your browser doesn't seem to support AJAX."; + } + } + } +} + +function rc(uri, k) { + var xhr = getXHR(); + + xhr.onreadystatechange = function() { + if (xhr.readyState == 4) + k(xhr.responseText); + }; + + xhr.open("GET", uri, true); + xhr.send(null); +} diff --git a/src/cjr.sml b/src/cjr.sml index 43a29a6c..a38a1b0d 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -113,6 +113,6 @@ datatype decl' = withtype decl = decl' located -type file = decl list * (Core.export_kind * string * int * typ list) list +type file = decl list * (Core.export_kind * string * int * typ list * typ) list end diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8f5c8551..6074ca3b 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1846,7 +1846,7 @@ fun p_file env (ds, ps) = E.declBinds env d)) env ds - val fields = foldl (fn ((ek, _, _, ts), fields) => + val fields = foldl (fn ((ek, _, _, ts, _), fields) => case ek of Core.Link => fields | Core.Rpc => fields @@ -1967,7 +1967,7 @@ fun p_file env (ds, ps) = string "}"] end - fun p_page (ek, s, n, ts) = + fun p_page (ek, s, n, ts, ran) = let val (ts, defInputs, inputsVar) = case ek of @@ -2054,12 +2054,14 @@ fun p_file env (ds, ps) = newline, string "if (*request == '/') ++request;", newline, - string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", - newline, - string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", - newline, - string "uw_write(ctx, \"\");", - newline, + box (case ek of + Core.Rpc => [] + | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", + newline, + string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");", + newline, + string "uw_write(ctx, \"\");", + newline]), box [string "{", newline, box (ListUtil.mapi (fn (i, t) => box [p_typ env t, @@ -2073,6 +2075,14 @@ fun p_file env (ds, ps) = string ";", newline]) ts), defInputs, + box (case ek of + Core.Rpc => [p_typ env ran, + space, + string "res", + space, + string "=", + space] + | _ => []), p_enamed env n, string "(", p_list_sep (box [string ",", space]) @@ -2082,8 +2092,10 @@ fun p_file env (ds, ps) = inputsVar, string ", uw_unit_v);", newline, - string "uw_write(ctx, \"\");", - newline, + box (case ek of + Core.Rpc => [] + | _ => [string "uw_write(ctx, \"\");", + newline]), string "return;", newline, string "}", diff --git a/src/cjrize.sml b/src/cjrize.sml index 77674158..16a82ec8 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -514,11 +514,12 @@ fun cifyDecl ((d, loc), sm) = (SOME (L'.DFunRec vis, loc), NONE, sm) end - | L.DExport (ek, s, n, ts) => + | L.DExport (ek, s, n, ts, t) => let val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts + val (t, sm) = cifyTyp (t, sm) in - (NONE, SOME (ek, "/" ^ s, n, ts), sm) + (NONE, SOME (ek, "/" ^ s, n, ts, t), sm) end | L.DTable (s, xts) => diff --git a/src/core.sml b/src/core.sml index 62f046fe..c6e0cfef 100644 --- a/src/core.sml +++ b/src/core.sml @@ -106,7 +106,7 @@ datatype exp' = | ELet of string * con * exp * exp - | EServerCall of int * exp list * exp + | EServerCall of int * exp list * exp * con withtype exp = exp' located diff --git a/src/core_print.sml b/src/core_print.sml index e9a36fbb..405ae14e 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -394,14 +394,14 @@ fun p_exp' par env (e, _) = newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, e) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, e, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] and p_exp env = p_exp' false env diff --git a/src/core_util.sml b/src/core_util.sml index 3d6808f9..a222dca4 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -482,7 +482,7 @@ fun compare ((e1, _), (e2, _)) = | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, e1), EServerCall (n2, es2, e2)) => + | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) => join (Int.compare (n1, n2), fn () => join (joinL compare (es1, es2), fn () => compare (e1, e2))) @@ -660,12 +660,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, e) => + | EServerCall (n, es, e, t) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => - S.map2 (mfe ctx e, + S.bind2 (mfe ctx e, fn e' => - (EServerCall (n, es', e'), loc))) + S.map2 (mfc ctx t, + fn t' => + (EServerCall (n, es', e', t'), loc)))) and mfp ctx (pAll as (p, loc)) = case p of diff --git a/src/jscomp.sml b/src/jscomp.sml index 627ba8f6..de671fef 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -98,7 +98,7 @@ fun varDepth (e, _) = | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e - | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es) + | EServerCall (_, es, ek, _) => foldl Int.max (varDepth ek) (map varDepth es) fun closedUpto d = let @@ -139,7 +139,7 @@ fun closedUpto d = | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e - | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek + | EServerCall (_, es, ek, _) => List.all (cu inner) es andalso cu inner ek in cu 0 end @@ -812,7 +812,15 @@ fun process file = st) end - | EServerCall _ => raise Fail "Jscomp EServerCall" + | EServerCall (x, es, ek, _) => + let + val (ek, st) = jsE inner (ek, st) + in + (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\","), + ek, + str ")"], + st) + end end in jsE diff --git a/src/mono.sml b/src/mono.sml index 547f8a55..ea2b9720 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -109,7 +109,7 @@ datatype exp' = | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of int * exp list * exp + | EServerCall of string * exp list * exp * typ withtype exp = exp' located @@ -117,7 +117,7 @@ datatype decl' = DDatatype of string * int * (string * int * typ option) list | DVal of string * int * typ * exp * string | DValRec of (string * int * typ * exp * string) list - | DExport of Core.export_kind * string * int * typ list + | DExport of Core.export_kind * string * int * typ list * typ | DTable of string * (string * typ) list | DSequence of string diff --git a/src/mono_print.sml b/src/mono_print.sml index a859a1bd..ba4c57f1 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -308,14 +308,14 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | EServerCall (n, es, e) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, es, e, _) => box [string "Server(", + string n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] and p_exp env = p_exp' false env @@ -378,19 +378,23 @@ fun p_decl env (dAll as (d, _) : decl) = p_list_sep (box [newline, string "and", space]) (p_vali env) vis] end - | DExport (ek, s, n, ts) => box [string "export", - space, - CorePrint.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] + | DExport (ek, s, n, ts, t) => box [string "export", + space, + CorePrint.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) => box [string "(* SQL table ", string s, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 7d39648a..2d0412fd 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -346,7 +346,7 @@ fun reduce file = | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] + | EServerCall (_, es, ek, _) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 34bd98be..4fd3caeb 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -44,7 +44,7 @@ type free = { fun shake file = let val page_es = List.foldl - (fn ((DExport (_, _, n, _), _), page_es) => n :: page_es + (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es | (_, page_es) => page_es) [] file val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) => diff --git a/src/mono_util.sml b/src/mono_util.sml index 13e0d32c..d1157218 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -350,12 +350,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fn e' => (ESignalSource e', loc)) - | EServerCall (n, es, ek) => + | EServerCall (n, es, ek, t) => S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es, fn es' => - S.map2 (mfe ctx ek, + S.bind2 (mfe ctx ek, fn ek' => - (EServerCall (n, es', ek'), loc))) + S.map2 (mft t, + fn t' => + (EServerCall (n, es', ek', t'), loc)))) in mfe end @@ -443,10 +445,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = fn vis' => (DValRec vis', loc)) end - | DExport (ek, s, n, ts) => - S.map2 (ListUtil.mapfold mft ts, + | DExport (ek, s, n, ts, t) => + S.bind2 (ListUtil.mapfold mft ts, fn ts' => - (DExport (ek, s, n, ts'), loc)) + S.map2 (mft t, + fn t' => + (DExport (ek, s, n, ts', t'), loc))) | DTable _ => S.return2 dAll | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll diff --git a/src/monoize.sml b/src/monoize.sml index fb1ac2f1..43c3f47d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2225,12 +2225,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall (n, es, ek) => + | L.EServerCall (n, es, ek, t) => let + val t = monoType env t + val (_, _, _, name) = Env.lookupENamed env n val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es val (ek, fm) = monoExp (env, st, fm) ek - in - ((L'.EServerCall (n, es, ek), loc), fm) + + val ekf = (L'.EAbs ("f", + (L'.TFun (t, + (L'.TFun ((L'.TRecord [], loc), + (L'.TRecord [], loc)), loc)), loc), + (L'.TFun (t, + (L'.TRecord [], loc)), loc), + (L'.EAbs ("x", + t, + (L'.TRecord [], loc), + (L'.EApp ((L'.EApp ((L'.ERel 1, loc), + (L'.ERel 0, loc)), loc), + (L'.ERecord [], loc)), loc)), loc)), loc) + val ek = (L'.EApp (ekf, ek), loc) + in + ((L'.EServerCall (name, es, ek, t), loc), fm) end end @@ -2280,16 +2296,18 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val (_, t, _, s) = Env.lookupENamed env n - fun unwind (t, _) = - case t of - L.TFun (dom, ran) => dom :: unwind ran + fun unwind (t, args) = + case #1 t of + L.TFun (dom, ran) => unwind (ran, dom :: args) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => - (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: unwind t - | _ => [] + unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args) + | _ => (rev args, t) - val ts = map (monoType env) (unwind 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), loc)]) + SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) end | L.DTable (x, n, (L.CRecord (_, xts), _), s) => let diff --git a/src/pathcheck.sml b/src/pathcheck.sml index ed6a4124..036d286f 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -46,7 +46,7 @@ fun checkDecl ((d, loc), (funcs, rels)) = (funcs, SS.add (rels, s))) in case d of - DExport (_, s, _, _) => + DExport (_, s, _, _, _) => (if SS.member (funcs, s) then E.errorAt loc ("Duplicate function path " ^ s) else diff --git a/src/reduce.sml b/src/reduce.sml index 89fce664..b428c01f 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -368,7 +368,7 @@ fun conAndExp (namedC, namedE) = | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) - | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc)) + | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc)) in {con = con, exp = exp} end diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 55bb5198..7de7d799 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -131,7 +131,7 @@ fun exp env (all as (e, loc)) = | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc) + | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc) fun reduce file = let diff --git a/src/rpcify.sml b/src/rpcify.sml index 09c44a7a..45d178ee 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -98,6 +98,29 @@ fun frob file = val serverSide = sideish (ssBasis, ssids) val clientSide = sideish (csBasis, csids) + val tfuncs = foldl + (fn ((d, _), tfuncs) => + let + fun doOne ((_, n, t, _, _), tfuncs) = + let + fun crawl ((t, _), args) = + case t of + CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran) + | TFun (arg, rest) => crawl (rest, arg :: args) + | _ => NONE + in + case crawl (t, []) 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) = case e of EApp ( @@ -130,8 +153,13 @@ fun frob file = exported = exported, export_decls = export_decls} + + val ran = + case IM.find (tfuncs, n) of + NONE => raise Fail "Rpcify: Undetected transaction function" + | SOME (_, ran) => ran in - (EServerCall (n, args, trans2), st) + (EServerCall (n, args, trans2, ran), st) end | _ => (e, st)) | _ => (e, st) diff --git a/src/shake.sml b/src/shake.sml index 58c1d2c6..4df64efa 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -116,7 +116,7 @@ fun shake file = in case e of ENamed n => check n - | EServerCall (n, _, _) => check n + | EServerCall (n, _, _, _) => check n | _ => s end diff --git a/tests/rpc.ur b/tests/rpc.ur index 85191229..b2e9722c 100644 --- a/tests/rpc.ur +++ b/tests/rpc.ur @@ -8,6 +8,8 @@ fun main () : transaction page = return