summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-09-13 19:16:07 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2014-09-13 19:16:07 -0400
commita7bfe57a2a355c5362d33e993394aa0bac300360 (patch)
tree1f81b256828f90ff34656d7d8fe703ce13d22e48 /src
parent6b6635f390cc072971dcc7b37af00bca21c48364 (diff)
parent5d2d4930568267b0e205ece3d4908cdc7ff715a1 (diff)
Merge.
Diffstat (limited to 'src')
-rw-r--r--src/c/http.c79
-rw-r--r--src/c/request.c30
-rw-r--r--src/c/urweb.c55
-rw-r--r--src/cjr.sml3
-rw-r--r--src/cjr_print.sml72
-rw-r--r--src/cjrize.sml20
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml25
-rw-r--r--src/corify.sml16
-rw-r--r--src/css.sml3
-rw-r--r--src/dbmodecheck.sig32
-rw-r--r--src/dbmodecheck.sml86
-rw-r--r--src/demo.sml2
-rw-r--r--src/elaborate.sml54
-rw-r--r--src/iflow.sml18
-rw-r--r--src/jscomp.sml18
-rw-r--r--src/mono.sml9
-rw-r--r--src/mono_opt.sml186
-rw-r--r--src/mono_reduce.sml22
-rw-r--r--src/monoize.sml768
-rw-r--r--src/pathcheck.sml2
-rw-r--r--src/prepare.sml16
-rw-r--r--src/prim.sig6
-rw-r--r--src/prim.sml16
-rw-r--r--src/scriptcheck.sml103
-rw-r--r--src/settings.sig6
-rw-r--r--src/settings.sml105
-rw-r--r--src/shake.sml2
-rw-r--r--src/sources3
-rw-r--r--src/sql.sml8
-rw-r--r--src/urweb.grm56
31 files changed, 1162 insertions, 660 deletions
diff --git a/src/c/http.c b/src/c/http.c
index 32dd1dd1..9651a216 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -23,6 +23,9 @@ extern uw_app uw_application;
int uw_backlog = SOMAXCONN;
static int keepalive = 0, quiet = 0;
+#define qfprintf(f, fmt, args...) do { if(!quiet) fprintf(f, fmt, ##args); } while(0)
+#define qprintf(fmt, args...) do { if(!quiet) printf(fmt, ##args); } while(0)
+
static char *get_header(void *data, const char *h) {
char *s = data;
int len = strlen(h);
@@ -86,8 +89,7 @@ static void *worker(void *data) {
sock = uw_dequeue();
}
- if (!quiet)
- printf("Handling connection with thread #%d.\n", me);
+ qprintf("Handling connection with thread #%d.\n", me);
while (1) {
int r;
@@ -95,8 +97,15 @@ static void *worker(void *data) {
if (back - buf == buf_size - 1) {
char *new_buf;
- buf_size *= 2;
- new_buf = realloc(buf, buf_size);
+ size_t new_buf_size = buf_size*2;
+ new_buf = realloc(buf, new_buf_size);
+ if(!new_buf) {
+ qfprintf(stderr, "Realloc failed while receiving header\n");
+ close(sock);
+ sock = 0;
+ break;
+ }
+ buf_size = new_buf_size;
back = new_buf + (back - buf);
buf = new_buf;
}
@@ -107,16 +116,14 @@ static void *worker(void *data) {
r = recv(sock, back, buf_size - 1 - (back - buf), 0);
if (r < 0) {
- if (!quiet)
- fprintf(stderr, "Recv failed\n");
+ qfprintf(stderr, "Recv failed while receiving header, retcode %d errno %m\n", r);
close(sock);
sock = 0;
break;
}
if (r == 0) {
- if (!quiet)
- printf("Connection closed.\n");
+ qprintf("Connection closed.\n");
close(sock);
sock = 0;
break;
@@ -146,9 +153,16 @@ static void *worker(void *data) {
while (back - body < clen) {
if (back - buf == buf_size - 1) {
char *new_buf;
- buf_size *= 2;
- new_buf = realloc(buf, buf_size);
-
+ size_t new_buf_size = buf_size * 2;
+ new_buf = realloc(buf, new_buf_size);
+ if(!new_buf) {
+ qfprintf(stderr, "Realloc failed while receiving content\n");
+ close(sock);
+ sock = 0;
+ goto done;
+ }
+
+ buf_size = new_buf_size;
back = new_buf + (back - buf);
body = new_buf + (body - buf);
s = new_buf + (s - buf);
@@ -159,16 +173,14 @@ static void *worker(void *data) {
r = recv(sock, back, buf_size - 1 - (back - buf), 0);
if (r < 0) {
- if (!quiet)
- fprintf(stderr, "Recv failed\n");
+ qfprintf(stderr, "Recv failed while receiving content, retcode %d errno %m\n", r);
close(sock);
sock = 0;
goto done;
}
if (r == 0) {
- if (!quiet)
- fprintf(stderr, "Connection closed.\n");
+ qfprintf(stderr, "Connection closed.\n");
close(sock);
sock = 0;
goto done;
@@ -236,8 +248,7 @@ static void *worker(void *data) {
uw_set_headers(ctx, get_header, headers);
uw_set_env(ctx, get_env, NULL);
- if (!quiet)
- printf("Serving URI %s....\n", path);
+ qprintf("Serving URI %s....\n", path);
rr = uw_request(rc, ctx, method, path, query_string, body, back - body,
on_success, on_failure,
NULL, log_error, log_debug,
@@ -301,7 +312,7 @@ static void *worker(void *data) {
}
static void help(char *cmd) {
- printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k] [-q]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\n", cmd);
+ printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe -T option sets socket recv timeout (0 disables timeout, default is 5 sec)", cmd);
}
static void sigint(int signum) {
@@ -316,6 +327,7 @@ int main(int argc, char *argv[]) {
struct sockaddr_in their_addr; // connector's address information
socklen_t sin_size;
int yes = 1, uw_port = 8080, nthreads = 1, i, *names, opt;
+ int recv_timeout_sec = 5;
signal(SIGINT, sigint);
signal(SIGPIPE, SIG_IGN);
@@ -323,7 +335,7 @@ int main(int argc, char *argv[]) {
my_addr.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
memset(my_addr.sin_zero, '\0', sizeof my_addr.sin_zero);
- while ((opt = getopt(argc, argv, "hp:a:t:kq")) != -1) {
+ while ((opt = getopt(argc, argv, "hp:a:t:kqT:")) != -1) {
switch (opt) {
case '?':
fprintf(stderr, "Unknown command-line option\n");
@@ -364,6 +376,15 @@ int main(int argc, char *argv[]) {
keepalive = 1;
break;
+ case 'T':
+ recv_timeout_sec = atoi(optarg);
+ if (recv_timeout_sec < 0) {
+ fprintf(stderr, "Invalid recv timeout\n");
+ help(argv[0]);
+ return 1;
+ }
+ break;
+
case 'q':
quiet = 1;
break;
@@ -405,8 +426,7 @@ int main(int argc, char *argv[]) {
sin_size = sizeof their_addr;
- if (!quiet)
- printf("Listening on port %d....\n", uw_port);
+ qprintf("Listening on port %d....\n", uw_port);
{
pthread_t thread;
@@ -434,17 +454,26 @@ int main(int argc, char *argv[]) {
int new_fd = accept(sockfd, (struct sockaddr *)&their_addr, &sin_size);
if (new_fd < 0) {
- if (!quiet)
- fprintf(stderr, "Socket accept failed\n");
+ qfprintf(stderr, "Socket accept failed\n");
} else {
- if (!quiet)
- printf("Accepted connection.\n");
+ qprintf("Accepted connection.\n");
if (keepalive) {
int flag = 1;
setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int));
}
+ if(recv_timeout_sec>0) {
+ int ret;
+ struct timeval tv;
+ memset(&tv, 0, sizeof(struct timeval));
+ tv.tv_sec = recv_timeout_sec;
+ ret = setsockopt(new_fd, SOL_SOCKET, SO_RCVTIMEO, (char *)&tv, sizeof(struct timeval));
+ if(ret != 0) {
+ qfprintf(stderr, "Timeout setting failed, errcode %d errno '%m'\n", ret);
+ }
+ }
+
uw_enqueue(new_fd);
}
}
diff --git a/src/c/request.c b/src/c/request.c
index 5aee7bbe..d621aea7 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -444,8 +444,13 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
int len = strlen(inputs);
if (len+1 > rc->queryString_size) {
+ char *qs = realloc(rc->queryString, len+1);
+ if(qs == NULL) {
+ log_error(logger_data, "queryString is too long (not enough memory)\n");
+ return FAILED;
+ }
+ rc->queryString = qs;
rc->queryString_size = len+1;
- rc->queryString = realloc(rc->queryString, len+1);
}
strcpy(rc->queryString, inputs);
@@ -480,8 +485,13 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
on_success(ctx);
if (path_len + 1 > rc->path_copy_size) {
+ char *pc = realloc(rc->path_copy, path_len + 1);
+ if(pc == NULL) {
+ log_error(logger_data, "Path is too long (not enough memory)\n");
+ return FAILED;
+ }
+ rc->path_copy = pc;
rc->path_copy_size = path_len + 1;
- rc->path_copy = realloc(rc->path_copy, rc->path_copy_size);
}
strcpy(rc->path_copy, path);
@@ -503,14 +513,14 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
had_error = 1;
strcpy(errmsg, uw_error_message(ctx));
} else {
+ try_rollback(ctx, 0, logger_data, log_error);
+
uw_write_header(ctx, "Content-type: text/html\r\n");
uw_write(ctx, "<html><head><title>Fatal Error</title></head><body>");
uw_write(ctx, "Fatal error: ");
uw_write(ctx, uw_error_message(ctx));
uw_write(ctx, "\n</body></html>");
- try_rollback(ctx, 0, logger_data, log_error);
-
return FAILED;
}
} else
@@ -527,14 +537,14 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
had_error = 1;
strcpy(errmsg, uw_error_message(ctx));
} else {
+ try_rollback(ctx, 0, logger_data, log_error);
+
uw_reset_keep_error_message(ctx);
on_failure(ctx);
uw_write_header(ctx, "Content-type: text/plain\r\n");
uw_write(ctx, "Fatal error (out of retries): ");
uw_write(ctx, uw_error_message(ctx));
uw_write(ctx, "\n");
-
- try_rollback(ctx, 0, logger_data, log_error);
return FAILED;
}
@@ -548,6 +558,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
had_error = 1;
strcpy(errmsg, uw_error_message(ctx));
} else {
+ try_rollback(ctx, 0, logger_data, log_error);
+
uw_reset_keep_error_message(ctx);
on_failure(ctx);
uw_write_header(ctx, "Content-type: text/html\r\n");
@@ -556,8 +568,6 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
uw_write(ctx, uw_error_message(ctx));
uw_write(ctx, "\n</body></html>");
- try_rollback(ctx, 0, logger_data, log_error);
-
return FAILED;
}
} else {
@@ -567,13 +577,13 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
had_error = 1;
strcpy(errmsg, "Unknown uw_handle return code");
} else {
+ try_rollback(ctx, 0, logger_data, log_error);
+
uw_reset_keep_request(ctx);
on_failure(ctx);
uw_write_header(ctx, "Content-type: text/plain\r\n");
uw_write(ctx, "Unknown uw_handle return code!\n");
- try_rollback(ctx, 0, logger_data, log_error);
-
return FAILED;
}
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 57762da8..51ce2735 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -441,7 +441,7 @@ struct uw_context {
const char *script_header;
- int needs_push, needs_sig, could_write_db;
+ int needs_push, needs_sig, could_write_db, at_most_one_query;
size_t n_deltas, used_deltas;
delta *deltas;
@@ -523,6 +523,7 @@ uw_context uw_init(int id, uw_loggers *lg) {
ctx->needs_push = 0;
ctx->needs_sig = 0;
ctx->could_write_db = 1;
+ ctx->at_most_one_query = 0;
ctx->source_count = 0;
@@ -791,7 +792,7 @@ failure_kind uw_begin(uw_context ctx, char *path) {
}
void uw_ensure_transaction(uw_context ctx) {
- if (!ctx->transaction_started) {
+ if (!ctx->transaction_started && !ctx->at_most_one_query) {
if (ctx->app->db_begin(ctx, ctx->could_write_db))
uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
ctx->transaction_started = 1;
@@ -1048,12 +1049,12 @@ int uw_set_file_input(uw_context ctx, const char *name, uw_Basis_file f) {
int n = ctx->app->input_num(name);
if (n < 0) {
- uw_set_error(ctx, "Bad file input name %s", uw_Basis_htmlifyString(ctx, name));
+ uw_set_error(ctx, "Bad file input name");
return -1;
}
if (n >= ctx->app->inputs_len) {
- uw_set_error(ctx, "For file input name %s, index %d is out of range", uw_Basis_htmlifyString(ctx, name), n);
+ uw_set_error(ctx, "For file input name, index %d is out of range", n);
return -1;
}
@@ -1210,6 +1211,10 @@ void uw_set_could_write_db(uw_context ctx, int n) {
ctx->could_write_db = n;
}
+void uw_set_at_most_one_query(uw_context ctx, int n) {
+ ctx->at_most_one_query = n;
+}
+
static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) {
if (b->back - b->front < extra) {
@@ -3317,6 +3322,8 @@ static char *find_sig(char *haystack) {
return s;
}
+static pthread_mutex_t message_send_mutex = PTHREAD_MUTEX_INITIALIZER;
+
int uw_commit(uw_context ctx) {
int i;
char *sig;
@@ -3336,10 +3343,17 @@ int uw_commit(uw_context ctx) {
}
}
+ // Here's an important lock to provide the abstraction that all messages from one transaction are sent as an atomic unit.
+ if (ctx->used_deltas > 0)
+ pthread_mutex_lock(&message_send_mutex);
+
if (ctx->transaction_started) {
int code = ctx->app->db_commit(ctx);
if (code) {
+ if (ctx->used_deltas > 0)
+ pthread_mutex_unlock(&message_send_mutex);
+
if (ctx->client)
release_client(ctx->client);
@@ -3356,7 +3370,7 @@ int uw_commit(uw_context ctx) {
if (ctx->transactionals[i].free)
ctx->transactionals[i].free(ctx->transactionals[i].data, 1);
- return 1;
+ return 1;
}
for (i = ctx->used_transactionals-1; i >= 0; --i)
@@ -3373,16 +3387,19 @@ int uw_commit(uw_context ctx) {
if (ctx->transactionals[i].commit) {
ctx->transactionals[i].commit(ctx->transactionals[i].data);
if (uw_has_error(ctx)) {
- if (ctx->client)
- release_client(ctx->client);
+ if (ctx->used_deltas > 0)
+ pthread_mutex_unlock(&message_send_mutex);
- for (i = ctx->used_transactionals-1; i >= 0; --i)
- if (ctx->transactionals[i].rollback != NULL)
- ctx->transactionals[i].rollback(ctx->transactionals[i].data);
+ if (ctx->client)
+ release_client(ctx->client);
- for (i = ctx->used_transactionals-1; i >= 0; --i)
- if (ctx->transactionals[i].free)
- ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].rollback != NULL)
+ ctx->transactionals[i].rollback(ctx->transactionals[i].data);
+
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].free)
+ ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
return 0;
}
@@ -3398,6 +3415,9 @@ int uw_commit(uw_context ctx) {
client_send(c, &d->msgs, ctx->script.start, uw_buffer_used(&ctx->script));
}
+ if (ctx->used_deltas > 0)
+ pthread_mutex_unlock(&message_send_mutex);
+
if (ctx->client)
release_client(ctx->client);
@@ -3617,7 +3637,7 @@ uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) {
static int mime_format(const char *s) {
for (; *s; ++s)
- if (!isalnum((int)*s) && *s != '/' && *s != '-' && *s != '.')
+ if (!isalnum((int)*s) && *s != '/' && *s != '-' && *s != '.' && *s != '+')
return 0;
return 1;
@@ -3859,6 +3879,11 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u
longjmp(ctx->jmp_buf, RETURN_INDIRECTLY);
}
+void uw_replace_page(uw_context ctx, const char *data, size_t size) {
+ uw_buffer_reset(&ctx->page);
+ ctx_uw_buffer_append(ctx, "page", &ctx->page, data, size);
+}
+
__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) {
cleanup *cl;
int len;
@@ -4269,7 +4294,7 @@ uw_Basis_bool uw_Basis_eq_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t
}
uw_Basis_bool uw_Basis_lt_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
- return !!(t1.seconds < t2.seconds || t1.microseconds < t2.microseconds);
+ return !!(t1.seconds < t2.seconds || (t1.seconds == t2.seconds && t1.microseconds < t2.microseconds));
}
uw_Basis_bool uw_Basis_le_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) {
diff --git a/src/cjr.sml b/src/cjr.sml
index 8cbabdcc..3742a06f 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -129,10 +129,11 @@ datatype decl' =
withtype decl = decl' located
datatype sidedness = datatype Mono.sidedness
+datatype dbmode = datatype Mono.dbmode
datatype effect = datatype Export.effect
datatype export_kind = datatype Export.export_kind
-type file = decl list * (export_kind * string * int * typ list * typ * sidedness * bool) list
+type file = decl list * (export_kind * string * int * typ list * typ * sidedness * dbmode * bool) list
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index af2340fe..b2e8d2a7 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -203,10 +203,10 @@ fun p_patMatch (env, disc) (p, loc) =
Prim.p_t_GCC (Prim.Int n),
string ")"]
| PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc),
- string ",",
- space,
- Prim.p_t_GCC (Prim.String s),
- string ")"]
+ string ",",
+ space,
+ Prim.p_t_GCC (Prim.String s),
+ string ")"]
| PPrim (Prim.Char ch) => box [string ("(" ^ disc),
space,
string "==",
@@ -503,16 +503,16 @@ fun getPargs (e, _) =
| ECase (e,
[((PNone _, _),
- (EPrim (Prim.String "NULL"), _)),
+ (EPrim (Prim.String (_, "NULL")), _)),
((PSome (_, (PVar _, _)), _),
(EFfiApp (m, x, [((ERel 0, _), _)]), _))],
{disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e))
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
- (EPrim (Prim.String "TRUE"), _)),
+ (EPrim (Prim.String (_, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
- (EPrim (Prim.String "FALSE"), _))],
+ (EPrim (Prim.String (_, "FALSE")), _))],
_) => [(e, Bool)]
| _ => raise Fail "CjrPrint: getPargs"
@@ -2218,7 +2218,7 @@ and p_exp' par tail env (e, loc) =
NONE => #nextval (Settings.currentDbms ()) {loc = loc,
seqE = p_exp' false false env seq,
seqName = case #1 seq of
- EPrim (Prim.String s) => SOME s
+ EPrim (Prim.String (_, s)) => SOME s
| _ => NONE}
| SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc,
id = id,
@@ -2634,7 +2634,7 @@ fun p_file env (ds, ps) =
end
| _ => NONE
- val fields = foldl (fn ((ek, _, _, ts, _, _, _), fields) =>
+ val fields = foldl (fn ((ek, _, _, ts, _, _, _, _), fields) =>
case ek of
Action eff =>
(case List.nth (ts, length ts - 2) of
@@ -2956,7 +2956,7 @@ fun p_file env (ds, ps) =
scripts (Settings.getScripts ())
end
- fun p_page (ek, s, n, ts, ran, side, tellSig) =
+ fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) =
let
val (ts, defInputs, inputsVar, fields) =
case ek of
@@ -3106,6 +3106,10 @@ fun p_file env (ds, ps) =
string (if couldWriteDb ek then "1" else "0"),
string ");",
newline,
+ string "uw_set_at_most_one_query(ctx, ",
+ string (case dbmode of OneQuery => "1" | _ => "0"),
+ string ");",
+ newline,
string "uw_set_needs_push(ctx, ",
string (case side of
ServerAndPullAndPush => "1"
@@ -3293,6 +3297,17 @@ fun p_file env (ds, ps) =
val now = Time.now ()
val nowD = Date.fromTimeUniv now
val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT"
+
+ fun hexifyByte (b : Word8.word) : string =
+ let
+ val s = Int.fmt StringCvt.HEX (Word8.toInt b)
+ in
+ "\\x" ^ (if size s < 2 then "0" else "") ^ s
+ end
+
+ fun hexify (v : Word8Vector.vector) : string =
+ String.concat (Word8Vector.foldr (fn (b, ls) =>
+ hexifyByte b :: ls) [] v)
in
box [string "#include \"",
string (OS.Path.joinDirFile {dir = !Settings.configInclude,
@@ -3520,9 +3535,9 @@ fun p_file env (ds, ps) =
string "}",
newline,
newline,
- string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
+ string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");",
newline,
- string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
+ string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
newline,
@@ -3532,6 +3547,37 @@ fun p_file env (ds, ps) =
newline],
string "}",
newline,
+ newline,
+
+ p_list_sep newline (fn r =>
+ box [string "if (!strcmp(request, \"",
+ string (String.toCString (#Uri r)),
+ string "\")) {",
+ newline,
+ box [(case #ContentType r of
+ NONE => box []
+ | SOME ct => box [string "uw_write_header(ctx, \"Content-Type: ",
+ string (String.toCString ct),
+ string "\\r\\n\");",
+ newline]),
+ string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt (Date.fromTimeUniv (#LastModified r)) ^ "\\r\\n\");"),
+ newline,
+ string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"),
+ newline,
+ string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
+ newline,
+ string "uw_replace_page(ctx, \"",
+ string (hexify (#Bytes r)),
+ string "\", ",
+ string (Int.toString (Word8Vector.length (#Bytes r))),
+ string ");",
+ newline,
+ string "return;",
+ newline],
+ string "};",
+ newline]) (Settings.listFiles ()),
+
+ newline,
p_list_sep newline (fn x => x) pds',
newline,
string "uw_clear_headers(ctx);",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index d153feff..11174162 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -242,7 +242,7 @@ fun cifyExp (eAll as (e, loc), sm) =
let
fun fail msg =
(ErrorMsg.errorAt loc msg;
- ((L'.EPrim (Prim.String ""), loc), sm))
+ ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm))
in
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
@@ -632,7 +632,7 @@ fun cifyDecl ((d, loc), sm) =
fun flatten e =
case #1 e of
L.ERecord [] => []
- | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
+ | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
| L.EStrcat (e1, e2) => flatten e1 @ flatten e2
| _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
Print.prefaces "Undetermined constraint"
@@ -640,7 +640,7 @@ fun cifyDecl ((d, loc), sm) =
[])
val pe = case #1 pe of
- L.EPrim (Prim.String s) => s
+ L.EPrim (Prim.String (_, s)) => s
| _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
Print.prefaces "Undetermined constraint"
[("e", MonoPrint.p_exp MonoEnv.empty pe)];
@@ -662,7 +662,7 @@ fun cifyDecl ((d, loc), sm) =
fun flatten e =
case #1 e of
L.ERecord [] => []
- | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
+ | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)]
| L.EStrcat (e1, e2) => flatten e1 @ flatten e2
| _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
Print.prefaces "Undetermined constraint"
@@ -670,7 +670,7 @@ fun cifyDecl ((d, loc), sm) =
[])
val e = case #1 e of
- L.EPrim (Prim.String s) => s
+ L.EPrim (Prim.String (_, s)) => s
| _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
Print.prefaces "Undetermined VIEW query"
[("e", MonoPrint.p_exp MonoEnv.empty e)];
@@ -730,12 +730,14 @@ fun cjrize (ds, sideInfo) =
end)
([], [], [], Sm.empty) ds
- val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo
+ val sideInfo = foldl (fn ((n, mode, dbmode), mp) => IM.insert (mp, n, (mode, dbmode))) IM.empty sideInfo
val ps = map (fn (ek, s, n, ts, t, _, b) =>
- (ek, s, n, ts, t,
- getOpt (IM.find (sideInfo, n), L'.ServerOnly),
- b)) ps
+ let
+ val (side, db) = getOpt (IM.find (sideInfo, n), (L'.ServerOnly, L'.AnyDb))
+ in
+ (ek, s, n, ts, t, side, db, b)
+ end) ps
in
(List.revAppend (dsF, rev ds),
ps)
diff --git a/src/compiler.sig b/src/compiler.sig
index 81d92694..fb0245ea 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -173,6 +173,7 @@ signature COMPILER = sig
val toNamejs : (string, Mono.file) transform
val toNamejs_untangle : (string, Mono.file) transform
val toScriptcheck : (string, Mono.file) transform
+ val toDbmodecheck : (string, Mono.file) transform
val toJscomp : (string, Mono.file) transform
val toMono_opt3 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 26e07e2a..d7ee8700 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2012, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -462,6 +462,8 @@ fun parseUrp' accLibs fname =
end
else
let
+ val thisPath = OS.Path.dir fname
+
val pathmap = ref (!pathmap)
val bigLibs = ref []
@@ -877,6 +879,13 @@ fun parseUrp' accLibs fname =
| "html5" => Settings.setIsHtml5 true
| "lessSafeFfi" => Settings.setLessSafeFfi true
+ | "file" =>
+ (case String.fields Char.isSpace arg of
+ [uri, fname] => (Settings.setFilePath thisPath;
+ Settings.addFile {Uri = uri,
+ LoadFromFilename = fname})
+ | _ => ErrorMsg.error "Bad 'file' arguments")
+
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
end
@@ -1393,12 +1402,19 @@ val scriptcheck = {
val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
+val dbmodecheck = {
+ func = DbModeCheck.classify,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toDbmodecheck = transform dbmodecheck "dbmodecheck" o toScriptcheck
+
val jscomp = {
func = JsComp.process,
print = MonoPrint.p_file MonoEnv.empty
}
-val toJscomp = transform jscomp "jscomp" o toScriptcheck
+val toJscomp = transform jscomp "jscomp" o toDbmodecheck
val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
@@ -1475,7 +1491,10 @@ val sqlify = {
val toSqlify = transform sqlify "sqlify" o toMono_opt2
-val escapeFilename = String.translate (fn #" " => "\\ " | #"\"" => "\\\"" | #"'" => "\\'" | ch => str ch)
+fun escapeFilename s =
+ "\""
+ ^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s
+ ^ "\""
val beforeC = ref (fn () => ())
diff --git a/src/corify.sml b/src/corify.sml
index b08ef7eb..5d58efcc 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1203,8 +1203,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t)
| _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc)
- val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc)
- val (e, tTrans) = if isTransactional t' then
+ val isTrans = isTransactional t'
+ val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' -
+ (if isTrans then
+ 0
+ else
+ 1), t', [])), loc)
+ val (e, tTrans) = if isTrans then
((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t')
else
(e, t')
@@ -1216,7 +1221,12 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
| Source.ServerOnly => Settings.addServerOnly name
| Source.JsFunc s => Settings.addJsFunc (name, s)) modes;
- if isTransactional t' andalso not (Settings.isBenignEffectful name) then
+ if List.exists (fn Source.JsFunc _ => true | _ => false) modes then
+ ()
+ else
+ Settings.addJsFunc (name, #2 name);
+
+ if isTrans andalso not (Settings.isBenignEffectful name) then
Settings.addEffectful name
else
();
diff --git a/src/css.sml b/src/css.sml
index 5db0c502..9e50686f 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -16,7 +16,7 @@
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -101,6 +101,7 @@ val tags = [("span", inline),
("submit", replaced),
("label", inline),
("ctextbox", replaced),
+ ("cpassword", replaced),
("button", replaced),
("ccheckbox", replaced),
("cselect", replaced),
diff --git a/src/dbmodecheck.sig b/src/dbmodecheck.sig
new file mode 100644
index 00000000..4d4873c4
--- /dev/null
+++ b/src/dbmodecheck.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2014, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature DB_MODE_CHECK = sig
+
+ val classify : Mono.file -> Mono.file
+
+end
diff --git a/src/dbmodecheck.sml b/src/dbmodecheck.sml
new file mode 100644
index 00000000..eb416cea
--- /dev/null
+++ b/src/dbmodecheck.sml
@@ -0,0 +1,86 @@
+(* Copyright (c) 2014, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure DbModeCheck :> DB_MODE_CHECK = struct
+
+open Mono
+
+structure IM = IntBinaryMap
+
+fun classify (ds, ps) =
+ let
+ fun mergeModes (m1, m2) =
+ case (m1, m2) of
+ (NoDb, _) => m2
+ | (_, NoDb) => m1
+ | _ => AnyDb
+
+ fun modeOf modes =
+ MonoUtil.Exp.fold {typ = fn (_, dbm) => dbm,
+ exp = fn (EQuery _, dbm) => mergeModes (OneQuery, dbm)
+ | (EDml _, _) => AnyDb
+ | (ENextval _, _) => AnyDb
+ | (ESetval _, _) => AnyDb
+ | (ENamed n, dbm) =>
+ (case IM.find (modes, n) of
+ NONE => dbm
+ | SOME dbm' => mergeModes (dbm, dbm'))
+ | (_, dbm) => dbm} NoDb
+
+ fun decl ((d, _), modes) =
+ case d of
+ DVal (x, n, _, e, _) => IM.insert (modes, n, modeOf modes e)
+ | DValRec xes =>
+ let
+ val mode = foldl (fn ((_, _, _, e, _), mode) =>
+ let
+ val mode' = modeOf modes e
+ in
+ case mode' of
+ NoDb => mode
+ | _ => AnyDb
+ end) NoDb xes
+ in
+ foldl (fn ((_, n, _, _, _), modes) => IM.insert (modes, n, mode)) modes xes
+ end
+ | _ => modes
+
+ val modes = foldl decl IM.empty ds
+
+ val (ps, modes) = ListUtil.foldlMap (fn ((n, side, _), modes) =>
+ case IM.find (modes, n) of
+ NONE => ((n, side, AnyDb), modes)
+ | SOME mode => ((n, side, mode), #1 (IM.remove (modes, n))))
+ modes ps
+
+ val ps = IM.foldli (fn (n, mode, ps) => (n, ServerOnly, mode) :: ps) ps modes
+ in
+ (ds, ps)
+ end
+
+end
+
diff --git a/src/demo.sml b/src/demo.sml
index 26dcfa95..17de80ee 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -410,7 +410,7 @@ fun make' {prefix, dirname, guided} =
app (fn rule =>
(TextIO.output (outf, "rewrite ");
TextIO.output (outf, case #pkind rule of
- Settings.Any => "any"
+ Settings.Any => "all"
| Settings.Url => "url"
| Settings.Table => "table"
| Settings.Sequence => "sequence"
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d492883f..c55dec01 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2013, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -1191,6 +1191,12 @@
(L'.CProj (c1, n1), _) => projSpecial1 (c1, n1, isRecord')
| (_, L'.CProj (c2, n2)) => projSpecial2 (c2, n2, isRecord')
| _ => isRecord' ()
+
+ fun maybeIsRecord c =
+ case c of
+ L'.CRecord _ => isRecord ()
+ | L'.CConcat _ => isRecord ()
+ | _ => err COccursCheckFailed
in
(*eprefaces "unifyCons''" [("c1", p_con env c1All),
("c2", p_con env c2All)];*)
@@ -1220,26 +1226,29 @@
else
err (fn _ => TooLifty (loc1, loc2))
- | (L'.CUnif (0, _, _, _, r as ref (L'.Unknown f)), _) =>
+ | (L'.CUnif (0, _, k1, _, r as ref (L'.Unknown f)), _) =>
+ (unifyKinds env k1 (kindof env c2All);
+ if occursCon r c2All then
+ maybeIsRecord c2
+ else if f c2All then
+ r := L'.Known c2All
+ else
+ err CScope)
+ | (_, L'.CUnif (0, _, k2, _, r as ref (L'.Unknown f))) =>
+ (unifyKinds env (kindof env c1All) k2;
+ if occursCon r c1All then
+ maybeIsRecord c1
+ else if f c1All then
+ r := L'.Known c1All
+ else
+ err CScope)
+
+ | (L'.CUnif (nl, _, k1, _, r as ref (L'.Unknown f)), _) =>
if occursCon r c2All then
- err COccursCheckFailed
- else if f c2All then
- r := L'.Known c2All
+ maybeIsRecord c2
else
- err CScope
- | (_, L'.CUnif (0, _, _, _, r as ref (L'.Unknown f))) =>
- if occursCon r c1All then
- err COccursCheckFailed
- else if f c1All then
- r := L'.Known c1All
- else
- err CScope
-
- | (L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f)), _) =>
- if occursCon r c2All then
- err COccursCheckFailed
- else
- (let
+ (unifyKinds env k1 (kindof env c2All);
+ let
val sq = squish nl c2All
in
if f sq then
@@ -1248,11 +1257,12 @@
err CScope
end
handle CantSquish => err (fn _ => TooDeep))
- | (_, L'.CUnif (nl, _, _, _, r as ref (L'.Unknown f))) =>
+ | (_, L'.CUnif (nl, _, k2, _, r as ref (L'.Unknown f))) =>
if occursCon r c1All then
- err COccursCheckFailed
+ maybeIsRecord c1
else
- (let
+ (unifyKinds env (kindof env c1All) k2;
+ let
val sq = squish nl c1All
in
if f sq then
diff --git a/src/iflow.sml b/src/iflow.sml
index 461dc956..40cf8993 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1446,7 +1446,7 @@ fun evalExp env (e as (_, loc)) k =
case es of
[_, (cname, _), _, _, _] =>
(case #1 cname of
- EPrim (Prim.String cname) =>
+ EPrim (Prim.String (_, cname)) =>
St.havocCookie cname
| _ => ())
| _ => ()
@@ -1637,7 +1637,7 @@ fun evalExp env (e as (_, loc)) k =
| Update (tab, _, _) =>
(cs, SS.add (ts, tab)))
| EFfiApp ("Basis", "set_cookie",
- [_, ((EPrim (Prim.String cname), _), _),
+ [_, ((EPrim (Prim.String (_, cname)), _), _),
_, _, _]) =>
(SS.add (cs, cname), ts)
| _ => st}
@@ -1765,7 +1765,7 @@ fun evalExp env (e as (_, loc)) k =
handle Cc.Contradiction => ())
end)
- | ENextval (EPrim (Prim.String seq), _) =>
+ | ENextval (EPrim (Prim.String (_, seq)), _) =>
let
val nv = St.nextVar ()
in
@@ -1775,7 +1775,7 @@ fun evalExp env (e as (_, loc)) k =
| ENextval _ => default ()
| ESetval _ => default ()
- | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String cname), _), _)]), _), _, _) =>
+ | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String (_, cname)), _), _)]), _), _, _) =>
let
val e = Var (St.nextVar ())
val e' = Func (Other ("cookie/" ^ cname), [])
@@ -1843,9 +1843,9 @@ fun nameSubexps k (e : Mono.exp) =
(e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e))
| ECase (e', ps as
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
- (EPrim (Prim.String "TRUE"), _)),
+ (EPrim (Prim.String (_, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
- (EPrim (Prim.String "FALSE"), _))], q) =>
+ (EPrim (Prim.String (_, "FALSE")), _))], q) =>
(e', fn e' => (ECase (e', ps, q), #2 e))
| _ => (e, fn x => x)
in
@@ -1907,7 +1907,7 @@ fun check (file : file) =
let
val ks =
case #1 pk of
- EPrim (Prim.String s) =>
+ EPrim (Prim.String (_, s)) =>
(case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of
[] => []
| pk => [pk])
@@ -1974,7 +1974,7 @@ fun check (file : file) =
| EFfi _ => e
| EFfiApp (m, f, es) =>
(case (m, f, es) of
- ("Basis", "set_cookie", [_, ((EPrim (Prim.String cname), _), _), _, _, _]) =>
+ ("Basis", "set_cookie", [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) =>
cookies := SS.add (!cookies, cname)
| _ => ();
(EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc))
@@ -2150,7 +2150,7 @@ fun check (file : file) =
| _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e
| PolSequence e =>
(case #1 e of
- EPrim (Prim.String seq) =>
+ EPrim (Prim.String (_, seq)) =>
let
val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0])
val outs = [Lvar 0]
diff --git a/src/jscomp.sml b/src/jscomp.sml
index bcabed0b..1a476739 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -55,7 +55,7 @@ type state = {
fun strcat loc es =
case es of
- [] => (EPrim (Prim.String ""), loc)
+ [] => (EPrim (Prim.String (Prim.Normal, "")), loc)
| [x] => x
| x :: es' => (EStrcat (x, strcat loc es'), loc)
@@ -81,7 +81,7 @@ fun process (file : file) =
| (_, state) => state)
(IM.empty, IM.empty) (#1 file)
- fun str loc s = (EPrim (Prim.String s), loc)
+ fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc)
fun isNullable (t, _) =
case t of
@@ -149,7 +149,7 @@ fun process (file : file) =
val (e', st) = quoteExp loc t ((ERel 0, loc), st)
in
(case #1 e' of
- EPrim (Prim.String "ERROR") => raise Fail "UHOH"
+ EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH"
| _ =>
(ECase (e,
[((PNone t, loc),
@@ -450,7 +450,7 @@ fun process (file : file) =
3)
in
case p of
- Prim.String s =>
+ Prim.String (_, s) =>
str ("\"" ^ String.translate jsChar s ^ "\"")
| Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"")
| _ => str (Prim.toString p)
@@ -519,7 +519,7 @@ fun process (file : file) =
fun deStrcat level (all as (e, loc)) =
case e of
- EPrim (Prim.String s) => jsifyStringMulti (level, s)
+ EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s)
| EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
| EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\""
| _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code";
@@ -1021,10 +1021,10 @@ fun process (file : file) =
case #1 e of
EPrim p =>
(case p of
- Prim.String s => if inString {needle = "<script", haystack = s} then
- foundJavaScript := true
- else
- ()
+ Prim.String (_, s) => if inString {needle = "<script", haystack = s} then
+ foundJavaScript := true
+ else
+ ()
| _ => ();
(e, st))
| ERel _ => (e, st)
diff --git a/src/mono.sml b/src/mono.sml
index 78740d70..1e402e57 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, 2013, Adam Chlipala
+(* Copyright (c) 2008-2010, 2013-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -162,6 +162,11 @@ datatype sidedness =
| ServerAndPull
| ServerAndPullAndPush
-type file = decl list * (int * sidedness) list
+datatype dbmode =
+ NoDb
+ | OneQuery
+ | AnyDb
+
+type file = decl list * (int * sidedness * dbmode) list
end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index ae306e68..d1e5ce55 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -145,7 +145,7 @@ fun checkProperty s = size s > 0
fun exp e =
case e of
- EPrim (Prim.String s) =>
+ EPrim (Prim.String (Prim.Html, s)) =>
if CharVector.exists Char.isSpace s then
let
val (_, chs) =
@@ -160,14 +160,14 @@ fun exp e =
end)
(false, []) s
in
- EPrim (Prim.String (String.implode (rev chs)))
+ EPrim (Prim.String (Prim.Html, String.implode (rev chs)))
end
else
e
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
-
- | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
+
+ | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) =>
let
val s =
if size s1 > 0 andalso size s2 > 0
@@ -177,10 +177,13 @@ fun exp e =
else
s1 ^ s2
in
- EPrim (Prim.String s)
+ EPrim (Prim.String (Prim.Html, s))
end
+
+ | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) =>
+ EPrim (Prim.String (Prim.Normal, s1 ^ s2))
- | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
+ | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EStrcat ((EPrim (Prim.String (Prim.Html, s2)), _), rest), _)) =>
let
val s =
if size s1 > 0 andalso size s2 > 0
@@ -190,9 +193,12 @@ fun exp e =
else
s1 ^ s2
in
- EStrcat ((EPrim (Prim.String s), loc), rest)
+ EStrcat ((EPrim (Prim.String (Prim.Html, s)), loc), rest)
end
+ | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EStrcat ((EPrim (Prim.String (_, s2)), _), rest), _)) =>
+ EStrcat ((EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), rest)
+
| EStrcat ((EStrcat (e1, e2), loc), e3) =>
optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
@@ -200,27 +206,27 @@ fun exp e =
ESeq ((optExp (EWrite e1, loc), loc),
(optExp (EWrite e2, loc), loc))
- | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
- (EWrite (EPrim (Prim.String s2), _), _)) =>
- EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
- | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
- (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
+ | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc),
+ (EWrite (EPrim (Prim.String (_, s2)), _), _)) =>
+ EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc)
+ | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc),
+ (ESeq ((EWrite (EPrim (Prim.String (_, s2)), _), _),
e), _)) =>
- ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
+ ESeq ((EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), loc),
e)
| EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) =>
- EPrim (Prim.String (htmlifySpecialChar ch))
+ EPrim (Prim.String (Prim.Html, htmlifySpecialChar ch))
| EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) =>
EFfiApp ("Basis", "htmlifySpecialChar_w", [e])
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) =>
- EPrim (Prim.String (htmlifyInt n))
+ EPrim (Prim.String (Prim.Html, htmlifyInt n))
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyInt", es)
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
(EPrim (Prim.Int n), _)), _), _)]) =>
- EPrim (Prim.String (htmlifyInt n))
+ EPrim (Prim.String (Prim.Html, htmlifyInt n))
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
e), loc), _)]) =>
EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))])
@@ -228,12 +234,12 @@ fun exp e =
EFfiApp ("Basis", "htmlifyInt_w", [e])
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) =>
- EPrim (Prim.String (htmlifyFloat n))
+ EPrim (Prim.String (Prim.Html, htmlifyFloat n))
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyFloat", es)
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
(EPrim (Prim.Float n), _)), _), _)]) =>
- EPrim (Prim.String (htmlifyFloat n))
+ EPrim (Prim.String (Prim.Html, htmlifyFloat n))
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
e), loc), _)]) =>
EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))])
@@ -242,18 +248,18 @@ fun exp e =
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
[((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) =>
- EPrim (Prim.String "True")
+ EPrim (Prim.String (Prim.Html, "True"))
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
[((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) =>
- EPrim (Prim.String "False")
+ EPrim (Prim.String (Prim.Html, "False"))
| EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyBool", es)
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) =>
- EPrim (Prim.String "True")
+ EPrim (Prim.String (Prim.Html, "True"))
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) =>
- EPrim (Prim.String "False")
+ EPrim (Prim.String (Prim.Html, "False"))
| EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
e), loc), _)]) =>
EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))])
@@ -267,106 +273,106 @@ fun exp e =
| EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
EFfiApp ("Basis", "htmlifyTime_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) =>
- EPrim (Prim.String (htmlifyString s))
- | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (htmlifyString s)), loc)
+ | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ EPrim (Prim.String (Prim.Html, htmlifyString s))
+ | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) =>
+ EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
EFfiApp ("Basis", "htmlifyString_w", [e])
- | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) =>
- EWrite (EPrim (Prim.String (htmlifyString s)), loc)
+ | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String (_, s)), loc), _)]) =>
+ EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) =>
EFfiApp ("Basis", "htmlifySource_w", [e])
| EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) =>
- EPrim (Prim.String (attrifyInt n))
+ EPrim (Prim.String (Prim.Html, attrifyInt n))
| EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (attrifyInt n)), loc)
+ EWrite (EPrim (Prim.String (Prim.Html, attrifyInt n)), loc)
| EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
EFfiApp ("Basis", "attrifyInt_w", [e])
| EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
- EPrim (Prim.String (attrifyFloat n))
+ EPrim (Prim.String (Prim.Html, attrifyFloat n))
| EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
+ EWrite (EPrim (Prim.String (Prim.Html, attrifyFloat n)), loc)
| EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
EFfiApp ("Basis", "attrifyFloat_w", [e])
- | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) =>
- EPrim (Prim.String (attrifyString s))
- | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (attrifyString s)), loc)
+ | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ EPrim (Prim.String (Prim.Html, attrifyString s))
+ | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) =>
+ EWrite (EPrim (Prim.String (Prim.Html, attrifyString s)), loc)
| EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
| EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) =>
- EPrim (Prim.String (attrifyChar s))
+ EPrim (Prim.String (Prim.Html, attrifyChar s))
| EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (attrifyChar s)), loc)
+ EWrite (EPrim (Prim.String (Prim.Html, attrifyChar s)), loc)
| EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) =>
EFfiApp ("Basis", "attrifyChar_w", [e])
- | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) =>
- EPrim (Prim.String s)
- | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) =>
- EWrite (EPrim (Prim.String s), loc)
+ | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ EPrim (Prim.String (Prim.Html, s))
+ | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]), loc) =>
+ EWrite (EPrim (Prim.String (Prim.Html, s)), loc)
| EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
| EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
- EPrim (Prim.String (urlifyInt n))
+ EPrim (Prim.String (Prim.Normal, urlifyInt n))
| EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (urlifyInt n)), loc)
+ EWrite (EPrim (Prim.String (Prim.Normal, urlifyInt n)), loc)
| EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
EFfiApp ("Basis", "urlifyInt_w", [e])
| EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
- EPrim (Prim.String (urlifyFloat n))
+ EPrim (Prim.String (Prim.Normal, urlifyFloat n))
| EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
+ EWrite (EPrim (Prim.String (Prim.Normal, urlifyFloat n)), loc)
| EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
EFfiApp ("Basis", "urlifyFloat_w", [e])
- | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) =>
- EPrim (Prim.String (urlifyString s))
- | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
- EWrite (EPrim (Prim.String (urlifyString s)), loc)
+ | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ EPrim (Prim.String (Prim.Normal, urlifyString s))
+ | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (Prim.Normal, s)), _), _)]), loc) =>
+ EWrite (EPrim (Prim.String (Prim.Normal, urlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
EFfiApp ("Basis", "urlifyString_w", [e])
| EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) =>
- EPrim (Prim.String "1")
+ EPrim (Prim.String (Prim.Normal, "1"))
| EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) =>
- EPrim (Prim.String "0")
+ EPrim (Prim.String (Prim.Normal, "0"))
| EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) =>
- EWrite (EPrim (Prim.String "1"), loc)
+ EWrite (EPrim (Prim.String (Prim.Normal, "1")), loc)
| EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) =>
- EWrite (EPrim (Prim.String "0"), loc)
+ EWrite (EPrim (Prim.String (Prim.Normal, "0")), loc)
| EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
EFfiApp ("Basis", "urlifyBool_w", [e])
| EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
- EPrim (Prim.String (sqlifyInt n))
+ EPrim (Prim.String (Prim.Normal, sqlifyInt n))
| EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) =>
- EPrim (Prim.String "NULL")
+ EPrim (Prim.String (Prim.Normal, "NULL"))
| EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) =>
- EPrim (Prim.String (sqlifyInt n))
+ EPrim (Prim.String (Prim.Normal, sqlifyInt n))
| EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
- EPrim (Prim.String (sqlifyFloat n))
+ EPrim (Prim.String (Prim.Normal, sqlifyFloat n))
| EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) =>
optExp (ECase (b,
[((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
- (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)),
+ (EPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc)),
((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
- (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))],
+ (EPrim (Prim.String (Prim.Normal, #falseString (Settings.currentDbms ()))), loc))],
{disc = (TFfi ("Basis", "bool"), loc),
result = (TFfi ("Basis", "string"), loc)}), loc)
- | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) =>
- EPrim (Prim.String (sqlifyString n))
+ | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String (_, n)), _), _)]) =>
+ EPrim (Prim.String (Prim.Normal, sqlifyString n))
| EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) =>
- EPrim (Prim.String (sqlifyChar n))
+ EPrim (Prim.String (Prim.Normal, sqlifyChar n))
| EWrite (ECase (discE, pes, {disc, ...}), loc) =>
optExp (ECase (discE,
@@ -388,11 +394,11 @@ fun exp e =
end
| EWrite (EQuery {exps, tables, state, query,
- initial = (EPrim (Prim.String ""), _),
- body = (EStrcat ((EPrim (Prim.String s), _),
+ initial = (EPrim (Prim.String (k, "")), _),
+ body = (EStrcat ((EPrim (Prim.String (_, s)), _),
(EStrcat ((ERel 0, _),
e'), _)), _)}, loc) =>
- if CharVector.all Char.isSpace s then
+ if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then
EQuery {exps = exps, tables = tables, query = query,
state = (TRecord [], loc),
initial = (ERecord [], loc),
@@ -401,7 +407,7 @@ fun exp e =
e
| EWrite (EQuery {exps, tables, state, query,
- initial = (EPrim (Prim.String ""), _),
+ initial = (EPrim (Prim.String (_, "")), _),
body}, loc) =>
let
fun passLets (depth, (e', _), lets) =
@@ -439,94 +445,94 @@ fun exp e =
| EWrite (ELet (x, t, e1, e2), loc) =>
optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
- | EWrite (EPrim (Prim.String ""), loc) =>
+ | EWrite (EPrim (Prim.String (_, "")), loc) =>
ERecord []
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
- | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkData s then
()
else
ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s);
se)
- | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkUrl s then
()
else
ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
se)
- | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkUrl s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkMime s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
se)
- | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkMime s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkAtom s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'");
se)
- | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkCssUrl s then
()
else
ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'");
se)
- | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if checkProperty s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'");
se)
- | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkRequestHeader s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'");
se)
- | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkRequestHeader s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkResponseHeader s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'");
se)
- | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkResponseHeader s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkEnvVar s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'");
se)
- | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
(if Settings.checkEnvVar s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -551,10 +557,10 @@ fun exp e =
#"_" :: cs => uwify (cs, ["uw_"])
| cs => uwify (cs, [])
in
- EPrim (Prim.String s)
+ EPrim (Prim.String (Prim.Normal, s))
end
- | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) =>
+ | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -576,11 +582,11 @@ fun exp e =
val s = uwify (String.explode s, [])
in
- EPrim (Prim.String s)
+ EPrim (Prim.String (Prim.Normal, s))
end
- | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) =>
- EPrim (Prim.String (unAs s))
+ | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) =>
+ EPrim (Prim.String (Prim.Normal, unAs s))
| EFfiApp ("Basis", "unAs", [(e', _)]) =>
let
fun parts (e as (_, loc)) =
@@ -589,7 +595,7 @@ fun exp e =
(case (parts s1, parts s2) of
(SOME p1, SOME p2) => SOME (p1 @ p2)
| _ => NONE)
- | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)]
+ | EPrim (Prim.String (_, s)) => SOME [(EPrim (Prim.String (Prim.Normal, unAs s)), loc)]
| EFfiApp ("Basis", f, [_]) =>
if String.isPrefix "sqlify" f then
SOME [e]
@@ -607,7 +613,7 @@ fun exp e =
end
| EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) =>
- EPrim (Prim.String (str ch))
+ EPrim (Prim.String (Prim.Normal, str ch))
| EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
EFfiApp ("Basis", "attrifyChar", [e])
| EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index c92ce5aa..50553560 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, 2013, Adam Chlipala
+(* Copyright (c) 2008, 2013-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -190,13 +190,13 @@ fun match (env, p : pat, e : exp) =
(PWild, _) => Yes env
| (PVar (x, t), _) => Yes ((x, t, e) :: env)
- | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
+ | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) =>
if String.isPrefix s' s then
Maybe
else
No
- | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) =>
+ | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) =>
if String.isSuffix s' s then
Maybe
else
@@ -471,7 +471,7 @@ fun reduce (file : file) =
| ECase (e, pes, _) =>
let
- val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
+ val lss = map (fn (p, e) => summarize (if d = ~1 then ~1 else d + patBinds p) e) pes
fun splitRel ls acc =
case ls of
@@ -502,7 +502,7 @@ fun reduce (file : file) =
| 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
+ | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2
| EClosure (_, es) => List.concat (map (summarize d) es)
@@ -510,7 +510,7 @@ fun reduce (file : file) =
List.concat [summarize d query,
summarize d initial,
[ReadDb],
- summarize (d + 2) body]
+ summarize (if d = ~1 then ~1 else d + 2) body]
| EDml (e, _) => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
@@ -585,7 +585,7 @@ fun reduce (file : file) =
val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
val effs_b = summarize 0 b
- (*val () = Print.fprefaces outf "Try"
+ (*val () = Print.prefaces "Try"
[(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
("e'", MonoPrint.p_exp env e'),
("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
@@ -685,7 +685,7 @@ fun reduce (file : file) =
map (fn (p, (EAbs (_, _, _, e), _)) =>
(p, swapExpVarsPat (0, patBinds p) e)
| (p, (EError (e, (TFun (_, t), _)), loc)) =>
- (p, (EError (e, t), loc))
+ (p, (EError (liftExpInExp (patBinds p) e, t), loc))
| (p, e) =>
(p, (EApp (liftExpInExp (patBinds p) e,
(ERel (patBinds p), loc)), loc)))
@@ -756,8 +756,10 @@ fun reduce (file : file) =
| ELet (x, t, e', b) => doLet (x, t, e', b)
- | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
- EPrim (Prim.String (s1 ^ s2))
+ | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) =>
+ EPrim (Prim.String ((case (k1, k2) of
+ (Prim.Html, Prim.Html) => Prim.Html
+ | _ => Prim.Normal), s1 ^ s2))
| ESignalBind ((ESignalReturn e1, loc), e2) =>
#1 (reduceExp env (EApp (e2, e1), loc))
diff --git a/src/monoize.sml b/src/monoize.sml
index f7344fed..6073a21f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -235,6 +235,7 @@ fun monoType env =
| L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "data_attr_kind") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
@@ -514,7 +515,7 @@ fun fooifyExp fk env =
let
val (_, _, _, s) = Env.lookupENamed env fnam
in
- ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
+ ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
end
| L'.EClosure (fnam, args) =>
let
@@ -530,21 +531,21 @@ fun fooifyExp fk env =
in
attrify (args, ft,
(L'.EStrcat (e,
- (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
arg'), loc)), loc),
fm)
end
| _ => (E.errorAt loc "Type mismatch encoding attribute";
(e, fm))
in
- attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
+ attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
end
| _ =>
case t of
- L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm)
+ L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
| L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
- | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
+ | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
| L'.TRecord ((x, t) :: xts) =>
let
val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
@@ -554,7 +555,7 @@ fun fooifyExp fk env =
val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
in
((L'.EStrcat (se,
- (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
se'), loc)), loc),
fm)
end) (se, fm) xts
@@ -584,14 +585,14 @@ fun fooifyExp fk env =
case to of
NONE =>
(((L'.PCon (dk, L'.PConVar n, NONE), loc),
- (L'.EPrim (Prim.String x), loc)),
+ (L'.EPrim (Prim.String (Prim.Normal, x)), loc)),
fm)
| SOME t =>
let
val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
in
(((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
arg), loc)),
fm)
end)
@@ -625,10 +626,10 @@ fun fooifyExp fk env =
in
((L'.ECase (e,
[((L'.PNone t, loc),
- (L'.EPrim (Prim.String "None"), loc)),
+ (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)),
((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc),
body), loc))],
{disc = tAll,
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
@@ -643,9 +644,9 @@ fun fooifyExp fk env =
val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
val branches = [((L'.PNone rt, loc),
- (L'.EPrim (Prim.String "Nil"), loc)),
+ (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
arg), loc))]
val dom = tAll
@@ -741,7 +742,7 @@ fun monoPat env (all as (p, loc)) =
fun strcat loc es =
case es of
- [] => (L'.EPrim (Prim.String ""), loc)
+ [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc)
| [e] => e
| _ =>
let
@@ -756,7 +757,7 @@ fun strcat loc es =
fun strcatComma loc es =
case es of
- [] => (L'.EPrim (Prim.String ""), loc)
+ [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc)
| [e] => e
| _ =>
let
@@ -765,11 +766,11 @@ fun strcatComma loc es =
in
foldr (fn (e, e') =>
case (e, e') of
- ((L'.EPrim (Prim.String ""), _), _) => e'
- | (_, (L'.EPrim (Prim.String ""), _)) => e
+ ((L'.EPrim (Prim.String (_, "")), _), _) => e'
+ | (_, (L'.EPrim (Prim.String (_, "")), _)) => e
| _ =>
(L'.EStrcat (e,
- (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
+ (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, ", ")), loc), e'), loc)), loc))
e1 es
end
@@ -787,7 +788,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val strcat = strcat loc
val strcatComma = strcatComma loc
- fun str s = (L'.EPrim (Prim.String s), loc)
+ fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
+ fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
fun poly () =
(E.errorAt loc "Unsupported expression";
@@ -1563,9 +1565,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
(L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
- (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String
- (Settings.getUrlPrefix ())),
- loc), s),
+ (L'.EFfiApp ("Basis", "set_cookie", [(str (Settings.getUrlPrefix ()), s),
((L'.ERel 2, loc), s),
(e, s),
(fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)),
@@ -1582,9 +1582,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.EFfiApp ("Basis", "clear_cookie",
- [((L'.EPrim (Prim.String
- (Settings.getUrlPrefix ())),
- loc), s),
+ [(str (Settings.getUrlPrefix ()), s),
((L'.ERel 1, loc), s)]),
loc)), loc)), loc),
fm)
@@ -1611,8 +1609,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
- ((L'.EPrim (Prim.String ""), loc),
- fm)
+ (str "", fm)
| L.ECApp (
(L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
nm), _),
@@ -1622,16 +1619,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
in
((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String
- (String.concatWith ", "
- (map (fn (x, _) =>
- Settings.mangleSql (monoNameLc env x)
- ^ (if #textKeysNeedLengths (Settings.currentDbms ())
- andalso isBlobby t then
- "(767)"
- else
- "")) unique))),
- loc)), loc),
+ (str
+ (String.concatWith ", "
+ (map (fn (x, _) =>
+ Settings.mangleSql (monoNameLc env x)
+ ^ (if #textKeysNeedLengths (Settings.currentDbms ())
+ andalso isBlobby t then
+ "(767)"
+ else
+ "")) unique)))),
+ loc),
fm)
end
@@ -1667,15 +1664,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val unique = (nm, t) :: unique
in
- ((L'.EPrim (Prim.String ("UNIQUE ("
- ^ String.concatWith ", "
- (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
- ^ (if #textKeysNeedLengths (Settings.currentDbms ())
- andalso isBlobby t then
- "(767)"
- else
- "")) unique)
- ^ ")")), loc),
+ (str ("UNIQUE ("
+ ^ String.concatWith ", "
+ (map (fn (x, t) => Settings.mangleSql (monoNameLc env x)
+ ^ (if #textKeysNeedLengths (Settings.currentDbms ())
+ andalso isBlobby t then
+ "(767)"
+ else
+ "")) unique)
+ ^ ")"),
fm)
end
@@ -1689,7 +1686,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi ("Basis", "mat_nil") =>
let
val string = (L'.TFfi ("Basis", "string"), loc)
- val stringE = (L'.EPrim (Prim.String ""), loc)
+ val stringE = str ""
in
((L'.ERecord [("1", stringE, string),
("2", stringE, string)], loc), fm)
@@ -1714,21 +1711,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc),
(L'.EAbs ("m", mat, mat,
(L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
- [((L'.PPrim (Prim.String ""), loc),
- (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))),
- loc), string),
- ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))),
- loc), string)], loc)),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)),
+ string),
+ ("2", str (Settings.mangleSql (lowercaseFirst nm2)),
+ string)], loc)),
((L'.PWild, loc),
(L'.ERecord [("1", (L'.EStrcat (
- (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1)
- ^ ", ")),
- loc),
+ str (Settings.mangleSql (lowercaseFirst nm1)
+ ^ ", "),
(L'.EField ((L'.ERel 0, loc), "1"), loc)),
loc), string),
("2", (L'.EStrcat (
- (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2)
- ^ ", ")), loc),
+ str (Settings.mangleSql (lowercaseFirst nm2)
+ ^ ", "),
(L'.EField ((L'.ERel 0, loc), "2"), loc)),
loc), string)],
loc))],
@@ -1737,10 +1733,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
- | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
- | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
- | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
+ | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm)
+ | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm)
+ | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm)
+ | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", fm)
| L.ECApp (
(L.ECApp (
@@ -1772,10 +1768,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun prop (fd, kw) =
(L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
- [((L'.PPrim (Prim.String "NO ACTION"), loc),
- (L'.EPrim (Prim.String ""), loc)),
+ [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc),
+ str ""),
((L'.PWild, loc),
- strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
+ strcat [str (" ON " ^ kw ^ " "),
(L'.EField ((L'.ERel 0, loc), fd), loc)])],
{disc = string,
result = string}), loc)
@@ -1783,13 +1779,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
(L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
(L'.EAbs ("pr", recd, string,
- strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
+ strcat [str "FOREIGN KEY (",
(L'.EField ((L'.ERel 2, loc), "1"), loc),
- (L'.EPrim (Prim.String ") REFERENCES "), loc),
+ str ") REFERENCES ",
(L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ("), loc),
+ str " (",
(L'.EField ((L'.ERel 2, loc), "2"), loc),
- (L'.EPrim (Prim.String ")"), loc),
+ str ")",
prop ("OnDelete", "DELETE"),
prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
fm)
@@ -1822,7 +1818,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val string = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("e", string, string,
- (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
+ (L'.EStrcat (str "CHECK ",
(L'.EFfiApp ("Basis", "checkString",
[((L'.ERel 0, loc), string)]), loc)), loc)), loc),
fm)
@@ -1851,19 +1847,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
val fields = map (fn (x, _) => (x, s)) fields
val rt = (L'.TRecord fields, loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc),
(L'.EAbs ("fs", rt, s,
- strcat [sc "INSERT INTO ",
+ strcat [str "INSERT INTO ",
(L'.ERel 1, loc),
- sc " (",
- strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields),
- sc ") VALUES (",
+ str " (",
+ strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields),
+ str ") VALUES (",
strcatComma (map (fn (x, _) =>
(L'.EField ((L'.ERel 0, loc),
x), loc)) fields),
- sc ")"]), loc)), loc),
+ str ")"]), loc)), loc),
fm)
end
| _ => poly ())
@@ -1875,31 +1870,30 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
val changed = map (fn (x, _) => (x, s)) changed
val rt = (L'.TRecord changed, loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e", s, s,
if #supportsUpdateAs (Settings.currentDbms ()) then
- strcat [sc "UPDATE ",
+ strcat [str "UPDATE ",
(L'.ERel 1, loc),
- sc " AS T_T SET ",
+ str " AS T_T SET ",
strcatComma (map (fn (x, _) =>
- strcat [sc (Settings.mangleSql x
+ strcat [str (Settings.mangleSql x
^ " = "),
(L'.EField
((L'.ERel 2,
loc),
x), loc)])
changed),
- sc " WHERE ",
+ str " WHERE ",
(L'.ERel 0, loc)]
else
- strcat [sc "UPDATE ",
+ strcat [str "UPDATE ",
(L'.ERel 1, loc),
- sc " SET ",
+ str " SET ",
strcatComma (map (fn (x, _) =>
- strcat [sc (Settings.mangleSql x
+ strcat [str (Settings.mangleSql x
^ " = "),
(L'.EFfiApp ("Basis", "unAs",
[((L'.EField
@@ -1908,7 +1902,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
x), loc),
s)]), loc)])
changed),
- sc " WHERE ",
+ str " WHERE ",
(L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]),
loc)), loc)), loc),
fm)
@@ -1918,19 +1912,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e", s, s,
if #supportsDeleteAs (Settings.currentDbms ()) then
- strcat [sc "DELETE FROM ",
+ strcat [str "DELETE FROM ",
(L'.ERel 1, loc),
- sc " AS T_T WHERE ",
+ str " AS T_T WHERE ",
(L'.ERel 0, loc)]
else
- strcat [sc "DELETE FROM ",
+ strcat [str "DELETE FROM ",
(L'.ERel 1, loc),
- sc " WHERE ",
+ str " WHERE ",
(L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc),
fm)
end
@@ -1990,7 +1983,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) =>
let
- fun sc s = (L'.EPrim (Prim.String s), loc)
val s = (L'.TFfi ("Basis", "string"), loc)
fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
in
@@ -1999,9 +1991,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
s,
strcat [gf "Rows",
(L'.ECase (gf "OrderBy",
- [((L'.PPrim (Prim.String ""), loc), sc ""),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""),
((L'.PWild, loc),
- strcat [sc " ORDER BY ",
+ strcat [str " ORDER BY ",
gf "OrderBy"])],
{disc = s, result = s}), loc),
gf "Limit",
@@ -2024,7 +2016,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
sexps), _),
_) =>
let
- fun sc s = (L'.EPrim (Prim.String s), loc)
val s = (L'.TFfi ("Basis", "string"), loc)
val b = (L'.TFfi ("Basis", "bool"), loc)
val un = (L'.TRecord [], loc)
@@ -2071,7 +2062,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))],
loc),
s,
- strcat [sc "SELECT ",
+ strcat [str "SELECT ",
(L'.ECase (gf "Distinct",
[((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
@@ -2079,41 +2070,41 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
con = "True",
arg = NONE},
NONE), loc),
- (L'.EPrim (Prim.String "DISTINCT "), loc)),
+ str "DISTINCT "),
((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "False",
arg = NONE},
NONE), loc),
- (L'.EPrim (Prim.String ""), loc))],
+ str "")],
{disc = b, result = s}), loc),
strcatComma (map (fn (x, t) =>
strcat [
(L'.EField (gf "SelectExps", x), loc),
- sc (" AS " ^ Settings.mangleSql x)
+ str (" AS " ^ Settings.mangleSql x)
]) sexps
@ map (fn (x, xts) =>
strcatComma
(map (fn (x', _) =>
- sc ("T_" ^ x
+ str ("T_" ^ x
^ "."
^ Settings.mangleSql x'))
xts)) stables),
(L'.ECase (gf "From",
- [((L'.PPrim (Prim.String ""), loc),
- sc ""),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ str ""),
((L'.PVar ("x", s), loc),
- strcat [sc " FROM ",
+ strcat [str " FROM ",
(L'.ERel 0, loc)])],
{disc = s,
result = s}), loc),
(L'.ECase (gf "Where",
- [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))),
+ [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))),
loc),
- sc ""),
+ str ""),
((L'.PWild, loc),
- strcat [sc " WHERE ", gf "Where"])],
+ strcat [str " WHERE ", gf "Where"])],
{disc = s,
result = s}), loc),
@@ -2124,14 +2115,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
List.all (fn (x, _) =>
List.exists (fn (x', _) => x' = x)
xts') xts) tables then
- sc ""
+ str ""
else
strcat [
- sc " GROUP BY ",
+ str " GROUP BY ",
strcatComma (map (fn (x, xts) =>
strcatComma
(map (fn (x', _) =>
- sc ("T_" ^ x
+ str ("T_" ^ x
^ "."
^ Settings.mangleSql x'))
xts)) grouped)
@@ -2139,10 +2130,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ECase (gf "Having",
[((L'.PPrim (Prim.String
- (#trueString (Settings.currentDbms ()))), loc),
- sc ""),
+ (Prim.Normal, #trueString (Settings.currentDbms ()))), loc),
+ str ""),
((L'.PWild, loc),
- strcat [sc " HAVING ", gf "Having"])],
+ strcat [str " HAVING ", gf "Having"])],
{disc = s,
result = s}), loc)
]), loc),
@@ -2208,6 +2199,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), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
fm)
+ | L.EFfi ("Basis", "sql_url") =>
+ ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
+ (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
+ fm)
| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
let
val t = monoType env t
@@ -2229,7 +2224,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
s,
(L'.ECase ((L'.ERel 0, loc),
[((L'.PNone t, loc),
- (L'.EPrim (Prim.String "NULL"), loc)),
+ str "NULL"),
((L'.PSome (t, (L'.PVar ("y", t), loc)), loc),
(L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))],
{disc = (L'.TOption t, loc),
@@ -2265,7 +2260,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ERecord [], loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) =>
- ((L'.EPrim (Prim.String ""), loc), fm)
+ (str "", fm)
| L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _),
_), _), _), _), _), _), _),
(L.CName name, _)) =>
@@ -2274,7 +2269,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EAbs ("tab", s, s,
strcat [(L'.ERel 0, loc),
- (L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc),
+ str (" AS T_" ^ name)]), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _),
@@ -2282,12 +2277,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.CName name, _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("q", s, s,
- strcat [sc "(",
+ strcat [str "(",
(L'.ERel 0, loc),
- sc (") AS T_" ^ name)]), loc),
+ str (") AS T_" ^ name)]), loc),
fm)
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) =>
@@ -2298,13 +2292,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("tab2", s, s,
(L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s),
("2", (L'.ERel 0, loc), s)], loc),
- [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc),
+ [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
(L'.ERel 0, loc)),
- ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc),
+ ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
(L'.ERel 1, loc)),
((L'.PWild, loc),
strcat [(L'.ERel 1, loc),
- (L'.EPrim (Prim.String ", "), loc),
+ str ", ",
(L'.ERel 0, loc)])],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
result = s}), loc)), loc)), loc),
@@ -2319,24 +2313,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("on", s, s,
(L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
("2", (L'.ERel 1, loc), s)], loc),
- [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc),
+ [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
(L'.ERel 1, loc)),
- ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc),
+ ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
strcat ((if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String "("), loc)]
+ [str "("]
else
[])
@ [(L'.ERel 2, loc),
- (L'.EPrim (Prim.String " JOIN "), loc),
+ str " JOIN ",
(L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
+ str " ON ",
(L'.ERel 0, loc)]
@ (if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String ")"), loc)]
+ [str ")"]
else
[])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
@@ -2355,27 +2349,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("on", s, s,
(L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
("2", (L'.ERel 1, loc), s)], loc),
- [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
+ [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 1, loc)),
- ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
+ ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
strcat ((if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String "("), loc)]
+ [str "("]
else
[])
@ [(L'.ERel 2, loc),
- (L'.EPrim (Prim.String " LEFT JOIN "),
- loc),
+ str " LEFT JOIN ",
(L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
+ str " ON ",
(L'.ERel 0, loc)]
@ (if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String ")"), loc)]
+ [str ")"]
else
[])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
@@ -2394,27 +2387,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("on", s, s,
(L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
("2", (L'.ERel 1, loc), s)], loc),
- [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
+ [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 1, loc)),
- ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
+ ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
strcat ((if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String "("), loc)]
+ [str "("]
else
[])
@ [(L'.ERel 2, loc),
- (L'.EPrim (Prim.String " RIGHT JOIN "),
- loc),
+ str " RIGHT JOIN ",
(L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
+ str " ON ",
(L'.ERel 0, loc)]
@ (if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String ")"), loc)]
+ [str ")"]
else
[])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
@@ -2433,27 +2425,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("on", s, s,
(L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s),
("2", (L'.ERel 1, loc), s)], loc),
- [((L'.PRecord [("1", (L'.PPrim (Prim.String ""),
+ [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 1, loc)),
- ((L'.PRecord [("2", (L'.PPrim (Prim.String ""),
+ ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")),
loc), s)], loc),
(L'.ERel 2, loc)),
((L'.PWild, loc),
strcat ((if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String "("), loc)]
+ [str "("]
else
[])
@ [(L'.ERel 2, loc),
- (L'.EPrim (Prim.String " FULL JOIN "),
- loc),
+ str " FULL JOIN ",
(L'.ERel 1, loc),
- (L'.EPrim (Prim.String " ON "), loc),
+ str " ON ",
(L'.ERel 0, loc)]
@ (if #nestedRelops
(Settings.currentDbms ()) then
- [(L'.EPrim (Prim.String ")"), loc)]
+ [str ")"]
else
[])))],
{disc = (L'.TRecord [("1", s), ("2", s)], loc),
@@ -2462,9 +2453,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
- ((L'.EPrim (Prim.String ""), loc), fm)
+ (str "", fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) =>
- ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm)
+ (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
@@ -2476,81 +2467,80 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("d", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
(L'.ECase ((L'.ERel 0, loc),
- [((L'.PPrim (Prim.String ""), loc),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
strcat [(L'.ERel 2, loc),
(L'.ERel 1, loc)]),
((L'.PWild, loc),
strcat [(L'.ERel 2, loc),
(L'.ERel 1, loc),
- sc ", ",
+ str ", ",
(L'.ERel 0, loc)])],
{disc = s, result = s}), loc)), loc)), loc)), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_no_limit") =>
- ((L'.EPrim (Prim.String ""), loc), fm)
+ (str "", fm)
| L.EFfiApp ("Basis", "sql_limit", [(e, t)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
- (L'.EPrim (Prim.String " LIMIT "), loc),
+ str " LIMIT ",
(L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
],
fm)
end
| L.EFfi ("Basis", "sql_no_offset") =>
- ((L'.EPrim (Prim.String ""), loc), fm)
+ (str "", fm)
| L.EFfiApp ("Basis", "sql_offset", [(e, t)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
- (L'.EPrim (Prim.String " OFFSET "), loc),
+ str " OFFSET ",
(L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
],
fm)
end
| L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) =>
- ((L'.EPrim (Prim.String "="), loc), fm)
+ (str "=", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) =>
- ((L'.EPrim (Prim.String "<>"), loc), fm)
+ (str "<>", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) =>
- ((L'.EPrim (Prim.String "<"), loc), fm)
+ (str "<", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) =>
- ((L'.EPrim (Prim.String "<="), loc), fm)
+ (str "<=", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) =>
- ((L'.EPrim (Prim.String ">"), loc), fm)
+ (str ">", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) =>
- ((L'.EPrim (Prim.String ">="), loc), fm)
+ (str ">=", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "+"), loc)), loc), fm)
+ str "+"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "-"), loc)), loc), fm)
+ str "-"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "*"), loc)), loc), fm)
+ str "*"), loc), fm)
| L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "/"), loc)), loc), fm)
+ str "/"), loc), fm)
| L.EFfi ("Basis", "sql_mod") =>
- ((L'.EPrim (Prim.String "%"), loc), fm)
+ (str "%", fm)
| L.EFfi ("Basis", "sql_like") =>
- ((L'.EPrim (Prim.String "LIKE"), loc), fm)
+ (str "LIKE", fm)
| L.ECApp (
(L.ECApp (
@@ -2565,21 +2555,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
- strcat [sc "(",
+ strcat [str "(",
(L'.ERel 1, loc),
- sc " ",
+ str " ",
(L'.ERel 0, loc),
- sc ")"]), loc)), loc),
+ str ")"]), loc)), loc),
fm)
end
- | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm)
+ | L.EFfi ("Basis", "sql_not") => (str "NOT", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "-"), loc)), loc), fm)
+ str "-"), loc), fm)
| L.ECApp (
(L.ECApp (
@@ -2596,22 +2585,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
- strcat [sc "(",
+ strcat [str "(",
(L'.ERel 1, loc),
- sc " ",
+ str " ",
(L'.ERel 2, loc),
- sc " ",
+ str " ",
(L'.ERel 0, loc),
- sc ")"]), loc)), loc)), loc),
+ str ")"]), loc)), loc)), loc),
fm)
end
- | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm)
- | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm)
+ | L.EFfi ("Basis", "sql_and") => (str "AND", fm)
+ | L.EFfi ("Basis", "sql_or") => (str "OR", fm)
| L.ECApp (
(L.ECApp (
@@ -2627,7 +2615,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
(L.CName tab, _)), _),
- (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm)
+ (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm)
| L.ECApp (
(L.ECApp (
@@ -2639,7 +2627,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
_), _),
_), _),
- (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm)
+ (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm)
| L.ECApp (
(L.ECApp (
@@ -2656,49 +2644,48 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
(if #nestedRelops (Settings.currentDbms ()) then
(L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
- strcat [sc "((",
+ strcat [str "((",
(L'.ERel 1, loc),
- sc ") ",
+ str ") ",
(L'.ERel 3, loc),
(L'.ECase ((L'.ERel 2, loc),
[((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE}, NONE), loc),
- sc " ALL"),
+ str " ALL"),
((L'.PWild, loc),
- sc "")],
+ str "")],
{disc = (L'.TFfi ("Basis", "bool"), loc),
result = s}), loc),
- sc " (",
+ str " (",
(L'.ERel 0, loc),
- sc "))"]), loc)), loc)), loc)), loc)
+ str "))"]), loc)), loc)), loc)), loc)
else
(L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
(L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("e2", s, s,
strcat [(L'.ERel 1, loc),
- sc " ",
+ str " ",
(L'.ERel 3, loc),
(L'.ECase ((L'.ERel 2, loc),
[((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis",
datatyp = "bool",
con = "True",
arg = NONE}, NONE), loc),
- sc " ALL"),
+ str " ALL"),
((L'.PWild, loc),
- sc "")],
+ str "")],
{disc = (L'.TFfi ("Basis", "bool"), loc),
result = s}), loc),
- sc " ",
+ str " ",
(L'.ERel 0, loc)]), loc)), loc)), loc)), loc),
fm)
end
@@ -2715,25 +2702,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
fm)
end
- | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
+ | L.EFfi ("Basis", "sql_union") => (str "UNION", fm)
| L.EFfi ("Basis", "sql_intersect") =>
(if #onlyUnion (Settings.currentDbms ()) then
ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT."
else
();
- ((L'.EPrim (Prim.String "INTERSECT"), loc), fm))
+ (str "INTERSECT", fm))
| L.EFfi ("Basis", "sql_except") =>
(if #onlyUnion (Settings.currentDbms ()) then
ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT."
else
();
- ((L'.EPrim (Prim.String "EXCEPT"), loc), fm))
+ (str "EXCEPT", fm))
| L.ECApp (
(L.ECApp (
@@ -2741,8 +2727,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.EFfi ("Basis", "sql_count"), _),
_), _),
_), _),
- _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
- fm)
+ _) => (str "COUNT(*)", fm)
| L.ECApp (
(L.ECApp (
@@ -2757,12 +2742,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
val main = strcat [(L'.ERel 1, loc),
- sc "(",
+ str "(",
(L'.ERel 0, loc),
- sc ")"]
+ str ")"]
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
@@ -2770,8 +2754,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) =>
- ((L'.EPrim (Prim.String "COUNT"), loc),
- fm)
+ (str "COUNT", fm)
| L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm)
| L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm)
@@ -2781,12 +2764,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "AVG"), loc)), loc),
+ str "AVG"), loc),
fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc),
+ str "SUM"), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm)
@@ -2806,16 +2789,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc),
+ str "MAX"), loc)), loc),
fm)
| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
+ str "MIN"), loc)), loc),
fm)
- | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
- | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
+ | L.EFfi ("Basis", "sql_asc") => (str "", fm)
+ | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
@@ -2827,7 +2810,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
fm)
@@ -2855,7 +2837,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
+ | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm)
| L.ECApp (
(L.ECApp (
@@ -2870,25 +2852,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("f", s, (L'.TFun (s, s), loc),
(L'.EAbs ("x", s, s,
strcat [(L'.ERel 1, loc),
- sc "(",
+ str "(",
(L'.ERel 0, loc),
- sc ")"]), loc)), loc),
+ str ")"]), loc)), loc),
fm)
end
| L.EFfi ("Basis", "sql_octet_length") =>
- ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then
- "octet_length"
- else
- "length")), loc), fm)
+ (str (if #supportsOctetLength (Settings.currentDbms ()) then
+ "octet_length"
+ else
+ "length"), fm)
| L.EFfi ("Basis", "sql_lower") =>
- ((L'.EPrim (Prim.String "lower"), loc), fm)
+ (str "lower", fm)
| L.EFfi ("Basis", "sql_upper") =>
- ((L'.EPrim (Prim.String "upper"), loc), fm)
+ (str "upper", fm)
| L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) =>
((L'.EFfi ("Basis", "sql_known"), loc), fm)
@@ -2902,12 +2883,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("s", s, s,
- strcat [sc "(",
+ strcat [str "(",
(L'.ERel 0, loc),
- sc " IS NULL)"]), loc),
+ str " IS NULL)"]), loc),
fm)
end
@@ -2921,15 +2901,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
(L'.EAbs ("x1", s, s,
- strcat [sc "COALESCE(",
+ strcat [str "COALESCE(",
(L'.ERel 1, loc),
- sc ",",
+ str ",",
(L'.ERel 0, loc),
- sc ")"]), loc)), loc),
+ str ")"]), loc)), loc),
fm)
end
@@ -2943,18 +2922,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _)) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("then", s, (L'.TFun (s, s), loc),
(L'.EAbs ("else", s, s,
- strcat [sc "(CASE WHEN (",
+ strcat [str "(CASE WHEN (",
(L'.ERel 2, loc),
- sc ") THEN (",
+ str ") THEN (",
(L'.ERel 1, loc),
- sc ") ELSE (",
+ str ") ELSE (",
(L'.ERel 0, loc),
- sc ") END)"]), loc)), loc)), loc),
+ str ") END)"]), loc)), loc)), loc),
fm)
end
@@ -2969,7 +2947,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
(L'.EAbs ("x", s, s,
@@ -2992,13 +2969,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
in
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
(L'.EAbs ("x", s, s,
- strcat [sc "(",
+ strcat [str "(",
(L'.ERel 0, loc),
- sc ")"]), loc)), loc),
+ str ")"]), loc)), loc),
fm)
end
@@ -3008,7 +2984,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.EFfi ("Basis", "sql_no_partition"), _),
_), _),
_), _),
- _) => ((L'.EPrim (Prim.String ""), loc), fm)
+ _) => (str "", fm)
| L.ECApp (
(L.ECApp (
(L.ECApp (
@@ -3021,7 +2997,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val s = (L'.TFfi ("Basis", "string"), loc)
in
- ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
+ ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc),
fm)
end
@@ -3041,20 +3017,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
val main = strcat [(L'.ERel 2, loc),
- sc " OVER (",
+ str " OVER (",
(L'.ERel 1, loc),
(L'.ECase ((L'.ERel 0, loc),
- [((L'.PPrim (Prim.String ""), loc),
- sc ""),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ str ""),
((L'.PWild, loc),
- strcat [sc " ORDER BY ",
+ strcat [str " ORDER BY ",
(L'.ERel 0, loc)])],
{disc = s,
result = s}), loc),
- sc ")"]
+ str ")"]
in
((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("p", s, (L'.TFun (s, s), loc),
@@ -3076,12 +3051,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
- fun sc s = (L'.EPrim (Prim.String s), loc)
val main = strcat [(L'.ERel 1, loc),
- sc "(",
+ str "(",
(L'.ERel 0, loc),
- sc ")"]
+ str ")"]
in
((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
(L'.EAbs ("e1", s, s, main), loc)), loc),
@@ -3089,9 +3063,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
- ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
+ (str "COUNT(*)", fm)
| L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
- ((L'.EPrim (Prim.String "RANK()"), loc), fm)
+ (str "RANK()", fm)
| L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
let
@@ -3107,27 +3081,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ESetval (e1, e2), loc), fm)
end
- | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm)
+ | L.EFfi ("Basis", "null") => (str "", fm)
| L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
let
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
in
- ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
+ ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
fm)
end
- | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) =>
+ | L.EFfi ("Basis", "data_kind") => (str "data-", fm)
+ | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm)
+
+ | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) =>
let
+ val (sk, fm) = monoExp (env, st, fm) sk
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
in
- ((L'.EStrcat ((L'.EPrim (Prim.String "data-"), loc),
+ ((L'.EStrcat (sk,
(L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc),
+ (L'.EStrcat (str "=\"",
(L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
- (L'.EPrim (Prim.String "\""), loc)), loc)),
+ str "\""), loc)),
loc)), loc)), loc),
fm)
end
@@ -3137,7 +3115,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
in
- ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
+ ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
fm)
end
@@ -3145,9 +3123,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val (s, fm) = monoExp (env, st, fm) s
in
- ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc),
+ ((L'.EStrcat (str "url(",
(L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
- (L'.EPrim (Prim.String ")"), loc)), loc)), loc),
+ str ")"), loc)), loc),
fm)
end
@@ -3156,7 +3134,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (s, fm) = monoExp (env, st, fm) s
in
((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc),
- (L'.EPrim (Prim.String ":"), loc)), loc),
+ str ":"), loc),
fm)
end
| L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) =>
@@ -3164,17 +3142,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
in
- ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
+ ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc),
fm)
end
- | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm)
+ | L.EFfi ("Basis", "noStyle") => (str "", fm)
| L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) =>
let
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
in
- ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc),
+ ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc),
fm)
end
@@ -3290,12 +3268,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
else
(NONE, NONE, attrs)
+ (* Special case for <button value=""> *)
+ val (attrs, extraString) = case tag of
+ "button" =>
+ (case List.partition (fn (x, _, _) => x = "Value") attrs of
+ ([(_, value, _)], rest) =>
+ (rest, SOME value)
+ | _ => (attrs, NONE))
+ | _ => (attrs, NONE)
+
+
val (class, fm) = monoExp (env, st, fm) class
val (dynClass, fm) = monoExp (env, st, fm) dynClass
val (style, fm) = monoExp (env, st, fm) style
val (dynStyle, fm) = monoExp (env, st, fm) dynStyle
- val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"]
+ val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script"]
fun isSome (e, _) =
case e of
@@ -3313,28 +3301,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun tagStart tag' =
let
val t = (L'.TFfi ("Basis", "string"), loc)
- val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc)
+ val s = strH (String.concat ["<", tag'])
val s = (L'.EStrcat (s,
(L'.ECase (class,
- [((L'.PPrim (Prim.String ""), loc),
- (L'.EPrim (Prim.String ""), loc)),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ strH ""),
((L'.PVar ("x", t), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
+ (L'.EStrcat (strH " class=\"",
(L'.EStrcat ((L'.ERel 0, loc),
- (L'.EPrim (Prim.String "\""), loc)),
+ strH "\""),
loc)), loc))],
{disc = t,
result = t}), loc)), loc)
val s = (L'.EStrcat (s,
(L'.ECase (style,
- [((L'.PPrim (Prim.String ""), loc),
- (L'.EPrim (Prim.String ""), loc)),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
+ strH ""),
((L'.PVar ("x", t), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc),
+ (L'.EStrcat (strH " style=\"",
(L'.EStrcat ((L'.ERel 0, loc),
- (L'.EPrim (Prim.String "\""), loc)),
+ strH "\""),
loc)), loc))],
{disc = t,
result = t}), loc)), loc)
@@ -3344,7 +3332,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| (("Data", e, _), (s, fm)) =>
((L'.EStrcat (s,
(L'.EStrcat (
- (L'.EPrim (Prim.String " "), loc),
+ strH " ",
e), loc)), loc),
fm)
| ((x, e, t), (s, fm)) =>
@@ -3361,7 +3349,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
arg = NONE},
NONE), loc),
(L'.EStrcat (s,
- (L'.EPrim (Prim.String s'), loc)), loc)),
+ strH s'), loc)),
((L'.PCon (L'.Enum,
L'.PConFfi {mod = "Basis",
datatyp = "bool",
@@ -3390,10 +3378,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EStrcat (s,
(L'.EStrcat (
- (L'.EPrim (Prim.String s'), loc),
+ strH s',
(L'.EStrcat (
(L'.EJavaScript (L'.Attribute, e), loc),
- (L'.EPrim (Prim.String ");return false'"), loc)), loc)),
+ strH ");return false'"), loc)),
loc)), loc),
fm)
end
@@ -3419,14 +3407,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (e, fm) = fooify env fm (e, t)
val e = case (tag, x) of
- ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc)
+ ("coption", "Value") => (L'.EStrcat (strH "x", e), loc)
| _ => e
in
((L'.EStrcat (s,
- (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
+ (L'.EStrcat (strH xp,
(L'.EStrcat (e,
- (L'.EPrim (Prim.String "\""),
- loc)),
+ strH "\""),
loc)),
loc)), loc),
fm)
@@ -3435,7 +3422,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
(if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then
(L'.EStrcat (s,
- (L'.EPrim (Prim.String " value=\"\""), loc)), loc)
+ strH " value=\"\""), loc)
else
s,
fm)
@@ -3448,8 +3435,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
- (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")),
- loc)), loc), fm)
+ strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
raise Fail "No name passed to input tag")
@@ -3464,11 +3450,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun normal () =
let
val (xml, fm) = monoExp (env, st, fm) xml
+
+ val xml = case extraString of
+ NONE => xml
+ | SOME extra => (L'.EStrcat (extra, xml), loc)
in
- ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
+ ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc),
(L'.EStrcat (xml,
- (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
- loc)), loc)),
+ strH (String.concat ["</", tag, ">"])), loc)),
loc),
fm)
end
@@ -3483,14 +3472,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
Substring.string bef)
end
in
- case xml of
- (L.EApp ((L.ECApp (
- (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
- _), _),
- _), _),
- (L.EPrim (Prim.String s), _)), _) =>
+ case (xml, extraString) of
+ ((L.EApp ((L.ECApp (
+ (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
+ _), _),
+ _), _),
+ (L.EPrim (Prim.String (_, s)), _)), _), NONE) =>
if CharVector.all Char.isSpace s andalso isSingleton () then
- ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm)
+ ((L'.EStrcat (tagStart, strH " />"), loc), fm)
else
normal ()
| _ => normal ()
@@ -3498,7 +3487,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun setAttrs jexp =
let
- val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
+ val s = strH (String.concat ["<", tag])
val assgns = List.mapPartial
(fn ("Source", _, _) => NONE
@@ -3547,12 +3536,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val t = (L'.TFfi ("Basis", "string"), loc)
val setClass = (L'.ECase (class,
- [((L'.PPrim (Prim.String ""), loc),
+ [((L'.PPrim (Prim.String (Prim.Normal, "")), loc),
str ""),
((L'.PVar ("x", t), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc),
+ (L'.EStrcat (strH "d.className=\"",
(L'.EStrcat ((L'.ERel 0, loc),
- (L'.EPrim (Prim.String "\";"), loc)), loc)),
+ strH "\";"), loc)),
loc))],
{disc = (L'.TOption t, loc),
result = t}), loc)
@@ -3571,14 +3560,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun execify e =
case e of
- NONE => (L'.EPrim (Prim.String ""), loc)
+ NONE => strH ""
| SOME e =>
let
val e = (L'.EApp (e, (L'.ERecord [], loc)), loc)
in
- (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc),
+ (L'.EStrcat (strH "exec(",
(L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc),
- (L'.EPrim (Prim.String ")"), loc)), loc)), loc)
+ strH ")"), loc)), loc)
end
fun inTag tag' = case ctxOuter of
@@ -3620,10 +3609,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
case attrs of
[("Signal", e, _)] =>
((L'.EStrcat
- ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
- ^ pnode () ^ "\", execD(")), loc),
+ (strH ("<script type=\"text/javascript\">dyn(\""
+ ^ pnode () ^ "\", execD("),
(L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
- (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+ strH ("))</script>")), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad <dyn> attributes"
end
@@ -3632,9 +3621,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
- ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc),
+ (strH "<script type=\"text/javascript\">active(execD(",
(L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
- (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+ strH "))</script>"), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad <active> attributes")
@@ -3642,15 +3631,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
- ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc),
+ (strH "<script type=\"text/javascript\">execF(execD(",
(L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
- (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
+ strH "))</script>"), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad <script> attributes")
| "submit" => normal ("input type=\"submit\"", NONE)
| "image" => normal ("input type=\"image\"", NONE)
- | "button" => normal ("input type=\"submit\"", NONE)
| "hidden" => input "hidden"
| "textbox" =>
@@ -3662,8 +3650,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
- (L'.EPrim (Prim.String (" type=\"text\" name=\"" ^ name ^ "\" />")),
- loc)), loc), fm)
+ strH (" type=\"text\" name=\"" ^ name ^ "\" />")),
+ loc), fm)
end
| SOME (_, src, _) =>
(strcat [str "<script type=\"text/javascript\">inp(exec(",
@@ -3683,10 +3671,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
- (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
+ strH (" name=\"" ^ name ^ "\">")), loc),
(L'.EStrcat (xml,
- (L'.EPrim (Prim.String "</textarea>"),
- loc)), loc)),
+ strH "</textarea>"), loc)),
loc), fm)
end
| _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
@@ -3706,7 +3693,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
NONE => raise Fail "No name for radioGroup"
| SOME name =>
normal ("input",
- SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
+ SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\""))))
| "select" =>
(case targs of
@@ -3716,11 +3703,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (xml, fm) = monoExp (env, st, fm) xml
in
((L'.EStrcat ((L'.EStrcat (ts,
- (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")),
- loc)), loc),
+ strH (" name=\"" ^ name ^ "\">")), loc),
(L'.EStrcat (xml,
- (L'.EPrim (Prim.String "</select>"),
- loc)), loc)),
+ strH "</select>"),
+ loc)),
loc),
fm)
end
@@ -3734,7 +3720,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (ts, fm) = tagStart "input"
in
((L'.EStrcat (ts,
- (L'.EPrim (Prim.String " type=\"text\" />"), loc)),
+ strH " type=\"text\" />"),
loc), fm)
end
| SOME (_, src, _) =>
@@ -3750,6 +3736,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end)
+ | "cpassword" =>
+ (case List.find (fn ("Source", _, _) => true | _ => false) attrs of
+ NONE =>
+ let
+ val (ts, fm) = tagStart "input"
+ in
+ ((L'.EStrcat (ts,
+ strH " type=\"password\" />"),
+ loc), fm)
+ end
+ | SOME (_, src, _) =>
+ let
+ val sc = strcat [str "password(exec(",
+ (L'.EJavaScript (L'.Script, src), loc),
+ str "))"]
+ val sc = setAttrs sc
+ in
+ (strcat [str "<script type=\"text/javascript\">",
+ sc,
+ str "</script>"],
+ fm)
+ end)
+
| "ccheckbox" =>
(case List.find (fn ("Source", _, _) => true | _ => false) attrs of
NONE =>
@@ -3757,7 +3766,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (ts, fm) = tagStart "input type=\"checkbox\""
in
((L'.EStrcat (ts,
- (L'.EPrim (Prim.String " />"), loc)),
+ strH " />"),
loc), fm)
end
| SOME (_, src, _) =>
@@ -3812,7 +3821,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (ts, fm) = tagStart "textarea"
in
((L'.EStrcat (ts,
- (L'.EPrim (Prim.String " />"), loc)),
+ strH " />"),
loc), fm)
end
| SOME (_, src, _) =>
@@ -3935,7 +3944,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => NotFound
val (func, action, fm) = case findSubmit xml of
- NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
+ NotFound => (0, strH "", fm)
| Error => raise Fail "Not ready for multi-submit lforms yet"
| Found (action, actionT) =>
let
@@ -3947,9 +3956,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (action, fm) = urlifyExp env fm (action, actionT)
in
(func,
- (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
+ (L'.EStrcat (strH " action=\"",
(L'.EStrcat (action,
- (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
+ strH "\""), loc)), loc),
fm)
end
@@ -3988,12 +3997,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val sigName = getSigName ()
val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
- val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
- ^ sigName
- ^ "\" value=\"")), loc),
+ val sigSet = (L'.EStrcat (strH ("<input type=\"hidden\" name=\""
+ ^ sigName
+ ^ "\" value=\""),
sigSet), loc)
val sigSet = (L'.EStrcat (sigSet,
- (L'.EPrim (Prim.String "\" />"), loc)), loc)
+ strH "\" />"), loc)
in
(L'.EStrcat (sigSet, xml), loc)
end
@@ -4002,7 +4011,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val action = if hasUpload then
(L'.EStrcat (action,
- (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc)
+ strH " enctype=\"multipart/form-data\""), loc)
else
action
@@ -4011,19 +4020,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val action = (L'.EStrcat (action,
(L'.ECase (class,
[((L'.PNone stt, loc),
- (L'.EPrim (Prim.String ""), loc)),
+ strH ""),
((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc),
+ (L'.EStrcat (strH " class=\"",
(L'.EStrcat ((L'.ERel 0, loc),
- (L'.EPrim (Prim.String "\""), loc)), loc)), loc))],
+ strH "\""), loc)), loc))],
{disc = (L'.TOption stt, loc),
result = stt}), loc)), loc)
in
- ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
+ ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"",
(L'.EStrcat (action,
- (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
+ strH ">"), loc)), loc),
(L'.EStrcat (xml,
- (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
+ strH "</form>"), loc)), loc),
fm)
end
@@ -4034,10 +4043,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
- strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\""
- ^ nm ^ "\" />")), loc),
+ strcat [strH ("<input type=\"hidden\" name=\".b\" value=\""
+ ^ nm ^ "\" />"),
(L'.ERel 0, loc),
- (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
+ strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
loc),
fm)
end
@@ -4049,10 +4058,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
- strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
- ^ nm ^ "\" />")), loc),
+ strcat [strH ("<input type=\"hidden\" name=\".s\" value=\""
+ ^ nm ^ "\" />"),
(L'.ERel 0, loc),
- (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
+ strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
loc),
fm)
end
@@ -4063,9 +4072,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val s = (L'.TFfi ("Basis", "string"), loc)
in
((L'.EAbs ("xml", s, s,
- strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc),
+ strcat [strH ("<input type=\"hidden\" name=\".i\" value=\"1\" />"),
(L'.ERel 0, loc),
- (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]),
+ strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]),
loc),
fm)
end
@@ -4153,7 +4162,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (e, fm) = monoExp (env, st, fm) e
val (e, fm) = urlifyExp env fm (e, dummyTyp)
in
- ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm)
+ ((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm)
end
| L.EApp (e1, e2) =>
@@ -4274,14 +4283,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (e, fm) = urlifyExp env fm (e, monoType env dom)
in
encodeArgs (es, ran, e
- :: (L'.EPrim (Prim.String "/"), loc)
+ :: str "/"
:: acc, fm)
end
| _ => raise Fail "Monoize: Not enough arguments visible in RPC function type"
val (call, fm) = encodeArgs (es, ft, [], fm)
val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc))
- (L'.EPrim (Prim.String name), loc) call
+ (str name) call
val unit = (L'.TRecord [], loc)
@@ -4307,6 +4316,9 @@ fun monoDecl (env, fm) (all as (d, loc)) =
(E.errorAt loc "Unsupported declaration";
Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
NONE)
+
+ fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
+ fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
in
case d of
L.DCon _ => NONE
@@ -4404,7 +4416,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSqlTable s
- val e_name = (L'.EPrim (Prim.String s), loc)
+ val e_name = str s
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4422,7 +4434,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSqlTable s
- val e_name = (L'.EPrim (Prim.String s), loc)
+ val e_name = str s
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
@@ -4440,7 +4452,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
val s = Settings.mangleSql s
- val e = (L'.EPrim (Prim.String s), loc)
+ val e = str s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
@@ -4452,7 +4464,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val e = (L'.EPrim (Prim.String s), loc)
+ val e = str s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
@@ -4463,7 +4475,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
val t = (L.CFfi ("Basis", "string"), loc)
val t' = (L'.TFfi ("Basis", "string"), loc)
- val e = (L'.EPrim (Prim.String s), loc)
+ val e = strH s
in
SOME (Env.pushENamed env x n t NONE s,
fm,
@@ -4488,7 +4500,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
(L'.TFfi ("Basis", "int"), loc)
else
un
-
+
val e2 = (L'.EAbs ("$x", t, (L'.TFun (un, un), loc),
(L'.EAbs ("$y", un, un,
(L'.EApp (
@@ -4559,6 +4571,9 @@ fun monoize env file =
val client = (L'.TFfi ("Basis", "client"), loc)
val unit = (L'.TRecord [], loc)
+ fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc)
+ fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc)
+
fun calcClientish xts =
foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
case #1 x of
@@ -4588,22 +4603,22 @@ fun monoize env file =
val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
- (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x
- ^ (case v of
- Client => ""
- | Channel => " >> 32")
- ^ " = ")), loc),
+ (L'.EStrcat (str (Settings.mangleSql x
+ ^ (case v of
+ Client => ""
+ | Channel => " >> 32")
+ ^ " = "),
target), loc)
val e =
foldl (fn ((x, v), e) =>
(L'.ESeq (
(L'.EDml ((L'.EStrcat (
- (L'.EPrim (Prim.String ("UPDATE "
- ^ Settings.mangleSql tab
- ^ " SET "
- ^ Settings.mangleSql x
- ^ " = NULL WHERE ")), loc),
+ str ("UPDATE "
+ ^ Settings.mangleSql tab
+ ^ " SET "
+ ^ Settings.mangleSql x
+ ^ " = NULL WHERE "),
cond (x, v)), loc), L'.Error), loc),
e), loc))
e nullable
@@ -4616,12 +4631,11 @@ fun monoize env file =
(L'.EDml (foldl
(fn (eb, s) =>
(L'.EStrcat (s,
- (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
- loc),
+ (L'.EStrcat (str " OR ",
cond eb), loc)), loc))
- (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM "
- ^ Settings.mangleSql tab
- ^ " WHERE ")), loc),
+ (L'.EStrcat (str ("DELETE FROM "
+ ^ Settings.mangleSql tab
+ ^ " WHERE "),
cond eb), loc)
ebs, L'.Error), loc),
e), loc)
@@ -4651,15 +4665,15 @@ fun monoize env file =
[] => e
| (x, _) :: ebs =>
(L'.ESeq (
- (L'.EDml ((L'.EPrim (Prim.String
- (foldl (fn ((x, _), s) =>
- s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
- ("UPDATE uw_"
- ^ tab
- ^ " SET "
- ^ Settings.mangleSql x
+ (L'.EDml (str
+ (foldl (fn ((x, _), s) =>
+ s ^ ", " ^ Settings.mangleSql x ^ " = NULL")
+ ("UPDATE uw_"
+ ^ tab
+ ^ " SET "
+ ^ Settings.mangleSql x
^ " = NULL")
- ebs)), loc), L'.Error), loc),
+ ebs), L'.Error), loc),
e), loc)
val e =
@@ -4667,8 +4681,8 @@ fun monoize env file =
[] => e
| eb :: ebs =>
(L'.ESeq (
- (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM "
- ^ Settings.mangleSql tab)), loc), L'.Error), loc),
+ (L'.EDml (str ("DELETE FROM "
+ ^ Settings.mangleSql tab), L'.Error), loc),
e), loc)
in
e
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index c1bb667b..3533032e 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -88,7 +88,7 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) =
val rels = #2 (doRel s)
val rels = case #1 pe of
- EPrim (Prim.String "") => rels
+ EPrim (Prim.String (_, "")) => rels
| _ =>
let
val s' = s ^ "_Pkey"
diff --git a/src/prepare.sml b/src/prepare.sml
index 89cd1b43..660173f0 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -65,7 +65,7 @@ fun prepString (e, st) =
SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1)
in
case #1 e of
- EPrim (Prim.String s) =>
+ EPrim (Prim.String (_, s)) =>
SOME (s :: ss, n)
| EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
(case prepString' (e1, ss, n) of
@@ -82,16 +82,16 @@ fun prepString (e, st) =
| ECase (e,
[((PNone _, _),
- (EPrim (Prim.String "NULL"), _)),
+ (EPrim (Prim.String (_, "NULL")), _)),
((PSome (_, (PVar _, _)), _),
(EFfiApp (m, x, [((ERel 0, _), _)]), _))],
{disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n)
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
- (EPrim (Prim.String "TRUE"), _)),
+ (EPrim (Prim.String (_, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _),
- (EPrim (Prim.String "FALSE"), _))],
+ (EPrim (Prim.String (_, "FALSE")), _))],
_) => doOne Bool
| _ => NONE
@@ -268,14 +268,14 @@ fun prepExp (e as (_, loc), st) =
if #supportsNextval (Settings.currentDbms ()) then
let
val s = case seq of
- (EPrim (Prim.String s), loc) =>
- (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
+ (EPrim (Prim.String (_, s)), loc) =>
+ (EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('" ^ s ^ "')")), loc)
| _ =>
let
val t = (TFfi ("Basis", "string"), loc)
- val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc)
+ val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String (Prim.Normal, "')")), loc), t)]), loc)
in
- (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc)
+ (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('")), loc), t), (s', t)]), loc)
end
in
case prepString (s, st) of
diff --git a/src/prim.sig b/src/prim.sig
index 74147471..1da53d33 100644
--- a/src/prim.sig
+++ b/src/prim.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -27,10 +27,12 @@
signature PRIM = sig
+ datatype string_mode = Normal | Html
+
datatype t =
Int of Int64.int
| Float of Real64.real
- | String of string
+ | String of string_mode * string
| Char of char
val p_t : t Print.printer
diff --git a/src/prim.sml b/src/prim.sml
index 94801e7f..1de4fc7b 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -27,10 +27,12 @@
structure Prim :> PRIM = struct
+datatype string_mode = Normal | Html
+
datatype t =
Int of Int64.int
| Float of Real64.real
- | String of string
+ | String of string_mode * string
| Char of char
open Print.PD
@@ -40,7 +42,7 @@ fun p_t t =
case t of
Int n => string (Int64.toString n)
| Float n => string (Real64.toString n)
- | String s => box [string "\"", string (String.toString s), string "\""]
+ | String (_, s) => box [string "\"", string (String.toString s), string "\""]
| Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""]
fun int2s n =
@@ -61,7 +63,7 @@ fun toString t =
case t of
Int n => int2s' n
| Float n => float2s n
- | String s => s
+ | String (_, s) => s
| Char ch => str ch
fun pad (n, ch, s) =
@@ -86,14 +88,14 @@ fun p_t_GCC t =
case t of
Int n => string (int2s n)
| Float n => string (float2s n)
- | String s => box [string "\"", string (toCString s), string "\""]
+ | String (_, s) => box [string "\"", string (toCString s), string "\""]
| Char ch => box [string "'", string (toCChar ch), string "'"]
fun equal x =
case x of
(Int n1, Int n2) => n1 = n2
| (Float n1, Float n2) => Real64.== (n1, n2)
- | (String s1, String s2) => s1 = s2
+ | (String (_, s1), String (_, s2)) => s1 = s2
| (Char ch1, Char ch2) => ch1 = ch2
| _ => false
@@ -108,7 +110,7 @@ fun compare (p1, p2) =
| (Float _, _) => LESS
| (_, Float _) => GREATER
- | (String n1, String n2) => String.compare (n1, n2)
+ | (String (_, n1), String (_, n2)) => String.compare (n1, n2)
| (String _, _) => LESS
| (_, String _) => GREATER
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index e5db476a..0d30ebcb 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2009, Adam Chlipala
+(* Copyright (c) 2009, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -29,6 +29,10 @@ structure ScriptCheck :> SCRIPT_CHECK = struct
open Mono
+structure SM = BinaryMapFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
structure SS = BinarySetFn(struct
type ord_key = string
val compare = String.compare
@@ -39,37 +43,108 @@ val pushBasis = SS.addList (SS.empty,
["new_channel",
"self"])
+datatype rpcmap =
+ Rpc of int (* ID of function definition *)
+ | Module of rpcmap SM.map
+
+fun lookup (r : rpcmap, k : string) =
+ let
+ fun lookup' (r, ks) =
+ case r of
+ Rpc x => SOME x
+ | Module m =>
+ case ks of
+ [] => NONE
+ | k :: ks' =>
+ case SM.find (m, k) of
+ NONE => NONE
+ | SOME r' => lookup' (r', ks')
+ in
+ lookup' (r, String.tokens (fn ch => ch = #"/") k)
+ end
+
+fun insert (r : rpcmap, k : string, v) =
+ let
+ fun insert' (r, ks) =
+ case r of
+ Rpc _ => Rpc v
+ | Module m =>
+ case ks of
+ [] => Rpc v
+ | k :: ks' =>
+ let
+ val r' = case SM.find (m, k) of
+ NONE => Module SM.empty
+ | SOME r' => r'
+ in
+ Module (SM.insert (m, k, insert' (r', ks')))
+ end
+ in
+ insert' (r, String.tokens (fn ch => ch = #"/") k)
+ end
+
+fun dump (r : rpcmap) =
+ case r of
+ Rpc _ => print "ROOT\n"
+ | Module m => (print "<Module>\n";
+ SM.appi (fn (k, r') => (print (k ^ ":\n");
+ dump r')) m;
+ print "</Module>\n")
+
fun classify (ds, ps) =
let
val proto = Settings.currentProtocol ()
fun inString {needle, haystack} = String.isSubstring needle haystack
- fun hasClient {basis, funcs, push} =
+ fun hasClient {basis, rpcs, funcs, push} =
MonoUtil.Exp.exists {typ = fn _ => false,
exp = fn ERecv _ => push
| EFfiApp ("Basis", x, _) => SS.member (basis, x)
| EJavaScript _ => not push
| ENamed n => IS.member (funcs, n)
+ | EServerCall (e, _, _, _) =>
+ let
+ fun head (e : exp) =
+ case #1 e of
+ EStrcat (e1, _) => head e1
+ | EPrim (Prim.String (_, s)) => SOME s
+ | _ => NONE
+ in
+ case head e of
+ NONE => true
+ | SOME fcall =>
+ case lookup (rpcs, fcall) of
+ NONE => true
+ | SOME n => IS.member (funcs, n)
+ end
| _ => false}
+ fun decl ((d, _), rpcs) =
+ case d of
+ DExport (Mono.Rpc _, fcall, n, _, _, _) =>
+ insert (rpcs, fcall, n)
+ | _ => rpcs
+
+ val rpcs = foldl decl (Module SM.empty) ds
+
fun decl ((d, _), (pull_ids, push_ids)) =
let
- val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false}
- val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true}
+ val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false}
+ val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true}
in
case d of
DVal (_, n, _, e, _) => (if hasClientPull e then
- IS.add (pull_ids, n)
- else
- pull_ids,
- if hasClientPush e then
- IS.add (push_ids, n)
- else
- push_ids)
+ IS.add (pull_ids, n)
+ else
+ pull_ids,
+ if hasClientPush e then
+ IS.add (push_ids, n)
+ else
+ push_ids)
| DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
- foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
- pull_ids xes
+ foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
+ pull_ids xes
else
pull_ids,
if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
@@ -98,7 +173,7 @@ fun classify (ds, ps) =
else if IS.member (pull_ids, n) then
ServerAndPull
else
- ServerOnly)) (IS.listItems all_ids)
+ ServerOnly, AnyDb)) (IS.listItems all_ids)
in
(ds, ps)
end
diff --git a/src/settings.sig b/src/settings.sig
index 29c4c506..9b32e502 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -278,4 +278,10 @@ signature SETTINGS = sig
val setLessSafeFfi : bool -> unit
val getLessSafeFfi : unit -> bool
+
+ val setFilePath : string -> unit
+ (* Sets the directory where we look for files being added below. *)
+
+ val addFile : {Uri : string, LoadFromFilename : string} -> unit
+ val listFiles : unit -> {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector} list
end
diff --git a/src/settings.sml b/src/settings.sml
index f00a4853..eb350c95 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -289,6 +289,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("strsuffix", "suf"),
("strlen", "slen"),
("strindex", "sidx"),
+ ("strsindex", "ssidx"),
("strchr", "schr"),
("substring", "ssub"),
("strcspn", "sspn"),
@@ -465,7 +466,7 @@ fun check f rules s =
val checkUrl = check (fn _ => true) url
-val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
+val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+")
val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
val checkMime = check validMime mime
@@ -743,4 +744,106 @@ val less = ref false
fun setLessSafeFfi b = less := b
fun getLessSafeFfi () = !less
+structure SM = BinaryMapFn(struct
+ type ord_key = string
+ val compare = String.compare
+ end)
+
+val noMimeFile = ref false
+
+fun noMime () =
+ (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n");
+ noMimeFile := true;
+ SM.empty)
+
+fun readMimeTypes () =
+ let
+ val inf = TextIO.openIn "/etc/mime.types"
+
+ fun loop m =
+ case TextIO.inputLine inf of
+ NONE => m
+ | SOME line =>
+ if size line > 0 andalso String.sub (line, 0) = #"#" then
+ loop m
+ else
+ case String.tokens Char.isSpace line of
+ typ :: exts =>
+ loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts)
+ | _ => loop m
+ in
+ loop SM.empty
+ before TextIO.closeIn inf
+ end handle IO.Io _ => noMime ()
+ | OS.SysErr _ => noMime ()
+
+val mimeTypes = ref (NONE : string SM.map option)
+
+fun getMimeTypes () =
+ case !mimeTypes of
+ SOME m => m
+ | NONE =>
+ let
+ val m = readMimeTypes ()
+ in
+ mimeTypes := SOME m;
+ m
+ end
+
+fun mimeTypeOf filename =
+ case OS.Path.ext filename of
+ NONE => (if !noMimeFile then
+ ()
+ else
+ TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n");
+ NONE)
+ | SOME ext =>
+ let
+ val to = SM.find (getMimeTypes (), ext)
+ in
+ case to of
+ NONE => if !noMimeFile then
+ ()
+ else
+ TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n")
+ | _ => ();
+ to
+ end
+
+val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map)
+
+val filePath = ref "."
+
+fun setFilePath path = filePath := path
+
+fun addFile {Uri, LoadFromFilename} =
+ let
+ val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename}
+ in
+ case SM.find (!files, Uri) of
+ SOME (path', _) =>
+ if path' = path then
+ ()
+ else
+ ErrorMsg.error ("Two different files requested for URI " ^ Uri)
+ | NONE =>
+ let
+ val inf = BinIO.openIn path
+ in
+ files := SM.insert (!files,
+ Uri,
+ (path,
+ {Uri = Uri,
+ ContentType = mimeTypeOf path,
+ LastModified = OS.FileSys.modTime path,
+ Bytes = BinIO.inputAll inf}));
+ BinIO.closeIn inf
+ end
+ end handle IO.Io _ =>
+ ErrorMsg.error ("Error loading file " ^ LoadFromFilename)
+ | OS.SysErr (s, _) =>
+ ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")")
+
+fun listFiles () = map #2 (SM.listItems (!files))
+
end
diff --git a/src/shake.sml b/src/shake.sml
index 57ebec8e..051507d8 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -44,7 +44,7 @@ type free = {
}
val dummyt = (TRecord (CRecord ((KType, ErrorMsg.dummySpan), []), ErrorMsg.dummySpan), ErrorMsg.dummySpan)
-val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan)
+val dummye = (EPrim (Prim.String (Prim.Normal, "")), ErrorMsg.dummySpan)
fun tupleC cs = (CTuple cs, ErrorMsg.dummySpan)
fun tupleE es = (ERecord (map (fn e => (dummyt, e, dummyt)) es), ErrorMsg.dummySpan)
diff --git a/src/sources b/src/sources
index a87678f9..8860b310 100644
--- a/src/sources
+++ b/src/sources
@@ -229,6 +229,9 @@ $(SRC)/cjrize.sml
$(SRC)/scriptcheck.sig
$(SRC)/scriptcheck.sml
+$(SRC)/dbmodecheck.sig
+$(SRC)/dbmodecheck.sml
+
$(SRC)/prepare.sig
$(SRC)/prepare.sml
diff --git a/src/sql.sml b/src/sql.sml
index 11df715c..8d245660 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -47,7 +47,7 @@ datatype chunk =
fun chunkify e =
case #1 e of
- EPrim (Prim.String s) => [String s]
+ EPrim (Prim.String (_, s)) => [String s]
| EStrcat (e1, e2) =>
let
val chs1 = chunkify e1
@@ -248,7 +248,7 @@ val prim =
(Option.map Prim.Int o Int64.fromString))
(opt (const "::int8"))) #1,
wrap (follow (opt (const "E")) (follow string (opt (const "::text"))))
- (Prim.String o #1 o #2)]
+ ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)]
fun known' chs =
case chs of
@@ -263,9 +263,9 @@ fun sqlify chs =
else
NONE
| Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _),
- (EPrim (Prim.String "TRUE"), _)),
+ (EPrim (Prim.String (Prim.Normal, "TRUE")), _)),
((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _),
- (EPrim (Prim.String "FALSE"), _))], _), _) :: chs =>
+ (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs =>
SOME (e, chs)
| _ => NONE
diff --git a/src/urweb.grm b/src/urweb.grm
index 157ecfac..edac345f 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -225,7 +225,7 @@ fun tagIn bt =
datatype prop_kind = Delete | Update
-datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * string * exp
fun patType loc (p : pat) =
case #1 p of
@@ -282,11 +282,11 @@ fun parseValue s pos =
in
(EApp ((EVar (["Basis"], "css_url", Infer), pos),
(EApp ((EVar (["Basis"], "bless", Infer), pos),
- (EPrim (Prim.String s), pos)), pos)), pos)
+ (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)), pos)
end
else
(EApp ((EVar (["Basis"], "atom", Infer), pos),
- (EPrim (Prim.String s), pos)), pos)
+ (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)
fun parseProperty s pos =
let
@@ -294,11 +294,11 @@ fun parseProperty s pos =
in
if Substring.isEmpty after then
(ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s);
- (EPrim (Prim.String ""), pos))
+ (EPrim (Prim.String (Prim.Normal, "")), pos))
else
foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos))
(EApp ((EVar (["Basis"], "property", Infer), pos),
- (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos)
+ (EPrim (Prim.String (Prim.Normal, Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos)
(String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE))))
end
@@ -486,7 +486,7 @@ fun patternOut (e : exp) =
| rpat of (string * pat) list * bool
| ptuple of pat list
- | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
| attr of attr
| attrv of exp
@@ -1152,8 +1152,8 @@ eapps : eterm (eterm)
| eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright))
eexp : eapps (case #1 eapps of
- EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc
- | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc
+ EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String (_, s)), loc)) => parseClass s loc
+ | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String (_, s)), loc)) => parseStyle s loc
| _ => eapps)
| FN eargs DARROW eexp (let
val loc = s (FNleft, eexpright)
@@ -1347,7 +1347,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
| INT (EPrim (Prim.Int INT), s (INTleft, INTright))
| FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
- | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+ | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
| CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
| path DOT idents (let
@@ -1396,7 +1396,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
else
ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
(EApp ((EVar (["Basis"], "cdata", Infer), loc),
- (EPrim (Prim.String ""), loc)),
+ (EPrim (Prim.String (Prim.Html, "")), loc)),
loc)
end)
| XML_BEGIN_END (let
@@ -1407,7 +1407,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
else
ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\".";
(EApp ((EVar (["Basis"], "cdata", Infer), loc),
- (EPrim (Prim.String ""), loc)),
+ (EPrim (Prim.String (Prim.Html, "")), loc)),
loc)
end)
@@ -1456,6 +1456,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
| UNDER (EWild, s (UNDERleft, UNDERright))
| LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright))
+ | LET eexp WHERE edecls END (ELet (edecls, eexp), s (LETleft, ENDright))
| LBRACK RBRACK (EVar (["Basis"], "Nil", Infer), s (LBRACKleft, RBRACKright))
@@ -1510,7 +1511,7 @@ pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright
| UNDER (PWild, s (UNDERleft, UNDERright))
| INT (PPrim (Prim.Int INT), s (INTleft, INTright))
| MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright))
- | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+ | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
| CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
| LPAREN pat RPAREN (pat)
| LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright))
@@ -1546,11 +1547,11 @@ xml : xmlOne xml (let
xmlOpt : xml (xml)
| (EApp ((EVar (["Basis"], "cdata", Infer), dummy),
- (EPrim (Prim.String ""), dummy)),
+ (EPrim (Prim.String (Prim.Html, "")), dummy)),
dummy)
xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)),
- (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
+ (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))),
s (NOTAGSleft, NOTAGSright))
| tag DIVIDE GT (let
val pos = s (tagleft, GTright)
@@ -1567,7 +1568,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
(EVar (["Basis"], "cdata", Infer), pos)
val cdata = (EApp (cdata,
- (EPrim (Prim.String ""), pos)),
+ (EPrim (Prim.String (Prim.Html, "")), pos)),
pos)
in
(EApp (#4 tag, cdata), pos)
@@ -1628,7 +1629,7 @@ tag : tagHead attrs (let
val e = (EVar (["Basis"], "tag", Infer), pos)
val eo = case #1 attrs of
NONE => (EVar (["Basis"], "null", Infer), pos)
- | SOME (EPrim (Prim.String s), pos) => parseClass s pos
+ | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos
| SOME e => e
val e = (EApp (e, eo), pos)
val eo = case #2 attrs of
@@ -1638,7 +1639,7 @@ tag : tagHead attrs (let
val e = (EApp (e, eo), pos)
val eo = case #3 attrs of
NONE => (EVar (["Basis"], "noStyle", Infer), pos)
- | SOME (EPrim (Prim.String s), pos) => parseStyle s pos
+ | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos
| SOME e => e
val e = (EApp (e, eo), pos)
val eo = case #4 attrs of
@@ -1651,10 +1652,11 @@ tag : tagHead attrs (let
[] => #6 attrs
| data :: datas =>
let
- fun doOne (name, value) =
+ fun doOne (kind, name, value) =
let
val e = (EVar (["Basis"], "data_attr", Infer), pos)
- val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
+ val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos)
+ val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos)
in
(EApp (e, value), pos)
end
@@ -1724,7 +1726,9 @@ attr : SYMBOL EQ attrv (case SYMBOL of
| "dynStyle" => DynStyle attrv
| _ =>
if String.isPrefix "data-" SYMBOL then
- Data (String.extract (SYMBOL, 5, NONE), attrv)
+ Data ("data", String.extract (SYMBOL, 5, NONE), attrv)
+ else if String.isPrefix "aria-" SYMBOL then
+ Data ("aria", String.extract (SYMBOL, 5, NONE), attrv)
else
let
val sym = makeAttr SYMBOL
@@ -1746,7 +1750,7 @@ attr : SYMBOL EQ attrv (case SYMBOL of
attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
| FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
- | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+ | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))
| LBRACE eexp RBRACE (eexp)
query : query1 obopt lopt ofopt (let
@@ -1980,6 +1984,14 @@ fitem : table' ([#1 table'], #2 table')
in
([tname], (EApp (e, query), loc))
end)
+ | LPAREN LBRACE LBRACE eexp RBRACE RBRACE RPAREN AS tname (let
+ val loc = s (LPARENleft, RPARENright)
+
+ val e = (EVar (["Basis"], "sql_from_query", Infer), loc)
+ val e = (ECApp (e, tname), loc)
+ in
+ ([tname], (EApp (e, eexp), loc))
+ end)
| LPAREN fitem RPAREN (fitem)
tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
@@ -2026,7 +2038,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In
s (INTleft, INTright)))
| FLOAT (sql_inject (EPrim (Prim.Float FLOAT),
s (FLOATleft, FLOATright)))
- | STRING (sql_inject (EPrim (Prim.String STRING),
+ | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)),
s (STRINGleft, STRINGright)))
| CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp",
s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright)))