diff options
| author |  Ziv Scully <ziv@mit.edu> | 2014-09-13 19:16:07 -0400 |
|---|---|---|
| committer | Ziv Scully <ziv@mit.edu> | 2014-09-13 19:16:07 -0400 |
| commit | a7bfe57a2a355c5362d33e993394aa0bac300360 (patch) | |
| tree | 1f81b256828f90ff34656d7d8fe703ce13d22e48 | |
| parent | 6b6635f390cc072971dcc7b37af00bca21c48364 (diff) | |
| parent | 5d2d4930568267b0e205ece3d4908cdc7ff715a1 (diff) | |
Merge.
68 files changed, 1490 insertions, 682 deletions
@@ -66,6 +66,8 @@ install-sh ltmain.sh missing +tests/*.db + syntax: regexp ^Makefile$ @@ -1,4 +1,48 @@ ======== +20140830 +======== + +- New HTML attribute: 'role' +- Bug fixes + +======== +20140819 +======== + +- Improvements to HTML model +- Bug fixes and optimization improvements + +======== +20140807 +======== + +- New .urp directive: 'file' +- Support for 'aria-*' attributes in HTML +- Default value of 'jsFunc' for less-safe FFI +- Client-side implementation of Basis function 'strsindex' +- Bug fixes and improvements to type inference and documentation + +======== +20140704 +======== + +- New syntactic shorthand for antiquoting subqueries +- New Top members: max and min +- 'sql_injectable_prim' instance for 'url' +- Bug fixes + +======== +20140615 +======== + +- New syntactic sugar: 'let E where DS end' for 'let DS in E end' +- Add 'onChange' attributes to more tags. +- New standard library function: String.trim +- Start treating Ur/Web tag <button> as real HTML tag <button>, + with special handling of 'value' attribute as tag content. +- Bug fixes + +======== 20140531 ======== diff --git a/configure.ac b/configure.ac index 2446a88e..2ff25580 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20140531]) +AC_INIT([urweb], [20140830]) WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS diff --git a/doc/manual.tex b/doc/manual.tex index 7fd135fa..0550d081 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -146,7 +146,8 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{database DBSTRING} sets the string to pass to libpq to open a database connection. \item \texttt{debug} saves some intermediate C files, which is mostly useful to help in debugging the compiler itself. \item \texttt{effectful Module.ident} registers an FFI function or transaction as having side effects. The optimizer avoids removing, moving, or duplicating calls to such functions. This is the default behavior for \texttt{transaction}-based types. -\item \texttt{exe FILENAME} sets the filename to which to write the output executable. The default for file \texttt{P.urp} is \texttt{P.exe}. +\item \texttt{exe FILENAME} sets the filename to which to write the output executable. The default for file \texttt{P.urp} is \texttt{P.exe}. +\item \texttt{file URI FILENAME} asks for the application executable to respond to requests for \texttt{URI} by serving a snapshot of the contents of \texttt{FILENAME} as of compile time. That is, the file contents are baked into the executable. System file \texttt{/etc/mime.types} is consulted (again, at compile time) to figure out the right MIME type to suggest in the HTTP response. \item \texttt{ffi FILENAME} reads the file \texttt{FILENAME.urs} to determine the interface to a new FFI module. The name of the module is calculated from \texttt{FILENAME} in the same way as for normal source files. See the files \texttt{include/urweb/urweb\_cpp.h} and \texttt{src/c/urweb.c} for examples of C headers and implementations for FFI modules. In general, every type or value \texttt{Module.ident} becomes \texttt{uw\_Module\_ident} in C. \item \texttt{html5} activates work-in-progress support for generating HTML5 instead of XHTML. For now, this option only affects the first few tokens on any page, which are always the same. \item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules. @@ -377,6 +378,10 @@ Compiled applications consult a few environment variables to modify their behavi \item \cd{URWEB\_PQ\_CON}: when using PostgreSQL, overrides the compiled-in connection string \end{itemize} +\subsection{A Word of Warning on Heuristic Compilation} + +For server-side code, Ur/Web follows an unusual compilation model, where not all type-correct programs can be compiled successfully, especially when using functions as data not known until runtime. See Section \ref{phases} for more detail. + \section{Ur Syntax} @@ -625,6 +630,8 @@ There are infix operator syntaxes for a number of functions defined in the $\mt{ A signature item $\mt{table} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{sql\_table} \; c \; []$. $\mt{view} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{sql\_view} \; c$, $\mt{sequence} \; x$ is short for $\mt{val} \; x : \mt{Basis}.\mt{sql\_sequence}$. $\mt{cookie} \; x : \tau$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{http\_cookie} \; \tau$, and $\mt{style} \; x$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{css\_class}$. +It is possible to write a $\mt{let}$ expression with its constituents in reverse order, along the lines of Haskell's \cd{where}. An expression $\mt{let} \; e \; \mt{where} \; ed^* \; \mt{end}$ desugars to $\mt{let} \; ed^* \; \mt{in} \; e \; \mt{end}$. + \section{Static Semantics} @@ -2058,7 +2065,7 @@ $$\begin{array}{l} We will not list here the different HTML tags and related functions from the standard library. They should be easy enough to understand from the code in \texttt{basis.urs}. The set of tags in the library is not yet claimed to be complete for HTML standards. Also note that there is currently no way for the programmer to add his own tags, without using the foreign function interface (Section \ref{ffi}). -Some tags support HTML5 \texttt{data-*} attributes, which in Ur/Web are encoded as a single attribute $\mt{Data}$ with type $\mt{data\_attrs}$ encoding one or more attributes of this kind. See \texttt{basis.urs} for details. The usual HTML5 syntax for these attributes is supported by the Ur/Web parser as syntactic sugar. +Some tags support HTML5 \texttt{data-*} attributes, which in Ur/Web are encoded as a single attribute $\mt{Data}$ with type $\mt{data\_attrs}$ encoding one or more attributes of this kind. See \texttt{basis.urs} for details. The usual HTML5 syntax for these attributes is supported by the Ur/Web parser as syntactic sugar, and the same mechanism is reused to support \texttt{aria-*} attributes. One last useful function is for aborting any page generation, returning some XML as an error message. This function takes the place of some uses of a general exception mechanism. $$\begin{array}{l} @@ -2278,7 +2285,7 @@ $$\begin{array}{rrcll} &&& \{\{e\}\} \; \mt{AS} \; \{c\} & \textrm{computed table expression, with computed local name} \\ \textrm{$\mt{FROM}$ items} & F &::=& T \mid \{\{e\}\} \mid F \; J \; \mt{JOIN} \; F \; \mt{ON} \; E \\ &&& \mid F \; \mt{CROSS} \; \mt{JOIN} \ F \\ - &&& \mid (Q) \; \mt{AS} \; t \\ + &&& \mid (Q) \; \mt{AS} \; t \mid (\{\{e\}\}) \; \mt{AS} \; t \\ \textrm{Joins} & J &::=& [\mt{INNER}] \\ &&& \mid [\mt{LEFT} \mid \mt{RIGHT} \mid \mt{FULL}] \; [\mt{OUTER}] \\ \textrm{SQL expressions} & E &::=& t.f & \textrm{column references} \\ @@ -2550,10 +2557,12 @@ Now \texttt{foo} is available as a normal function. If called in server-side co \item \texttt{jsFunc "putJsFuncNameHere"} \end{itemize} +When no \texttt{jsFunc} directive is present, the function is assumed to map to a JavaScript function of the same name, if used in a client-side context. + -\section{Compiler Phases} +\section{\label{phases}Compiler Phases} -The Ur/Web compiler is unconventional in that it relies on a kind of \emph{heuristic compilation}. Not all valid programs will compile successfully. Informally, programs fail to compile when they are ``too higher order.'' Compiler phases do their best to eliminate different kinds of higher order-ness, but some programs just won't compile. This is a trade-off for producing very efficient executables. Compiled Ur/Web programs use native C representations and require no garbage collection. +The Ur/Web compiler is unconventional in that it relies on a kind of \emph{heuristic compilation}. Not all valid programs will compile successfully. Informally, programs fail to compile when they are ``too higher order.'' Compiler phases do their best to eliminate different kinds of higher order-ness, but some programs just won't compile. This is a trade-off for producing very efficient executables. Compiled Ur/Web programs use native C representations and require no garbage collection. Also, this warning only applies to server-side code, as client-side code runs in a normal JavaScript environment with garbage collection. In this section, we step through the main phases of compilation, noting what consequences each phase has for effective programming. diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index ea733c8c..39dc0bc0 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -94,6 +94,7 @@ uw_Basis_string uw_Basis_maybe_onunload(struct uw_context *, uw_Basis_string); void uw_set_needs_push(struct uw_context *, int); void uw_set_needs_sig(struct uw_context *, int); void uw_set_could_write_db(struct uw_context *, int); +void uw_set_at_most_one_query(struct uw_context *, int); char *uw_Basis_htmlifyInt(struct uw_context *, uw_Basis_int); char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float); @@ -267,6 +268,7 @@ void uw_mayReturnIndirectly(struct uw_context *); __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url); +void uw_replace_page(struct uw_context *, const char *data, size_t size); uw_Basis_time uw_Basis_now(struct uw_context *); uw_Basis_time uw_Basis_addSeconds(struct uw_context *, uw_Basis_time, uw_Basis_int); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index c3cab50a..5cc49fec 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1050,6 +1050,18 @@ function inp(s, name) { return x; } +function password(s, name) { + if (suspendScripts) + return; + + var x = input(document.createElement("input"), s, + function(x) { return function(v) { if (x.value != v) x.value = v; }; }, "password", name); + x.value = s.data; + x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, x.value) }; + + return x; +} + function selectValue(x) { if (x.options.length == 0) return ""; @@ -1212,6 +1224,13 @@ function sidx(s, ch) { else return r; } +function ssidx(h, n) { + var r = h.indexOf(n); + if (r == -1) + return null; + else + return r; +} function sspn(s, chs) { for (var i = 0; i < s.length; ++i) if (chs.indexOf(s.charAt(i)) != -1) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index ce864563..5d0a0c8a 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -703,6 +703,7 @@ type css_value val atom : string -> css_value type url val css_url : url -> css_value +val sql_url : sql_injectable_prim url type css_property val property : string -> css_property val value : css_property -> css_value -> css_property @@ -796,9 +797,13 @@ val active : unit val script : unit -> tag [Code = transaction unit] head [] [] [] -(* Type for HTML5 "data-*" attributes. *) +(* Type for HTML5 "data-*" and "aria-*" attributes. *) +type data_attr_kind +val data_kind : data_attr_kind +val aria_kind : data_attr_kind + type data_attr -val data_attr : string (* Key *) -> string (* Value *) -> data_attr +val data_attr : data_attr_kind -> string (* Key *) -> string (* Value *) -> data_attr (* This function will fail if the key doesn't meet HTML's lexical rules! *) val data_attrs : data_attr -> data_attr -> data_attr @@ -843,7 +848,7 @@ con scrollEvents = [Onscroll = transaction unit] con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents con tableEvents = focusEvents ++ mouseEvents ++ keyEvents -con boxAttrs = [Data = data_attr, Id = id, Title = string] ++ boxEvents +con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string] ++ boxEvents con tableAttrs = [Data = data_attr, Id = id, Title = string] ++ tableEvents val span : bodyTag boxAttrs @@ -946,11 +951,11 @@ con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => val hidden : formTag string [] [Data = data_attr, Id = string, Value = string] val textbox : formTag string [] ([Value = string, Size = int, Placeholder = string, Source = source string, Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs) -val password : formTag string [] ([Value = string, Size = int, Placeholder = string] ++ boxAttrs) +val password : formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs) val textarea : formTag string [] ([Rows = int, Cols = int, Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs) -val checkbox : formTag bool [] ([Checked = bool] ++ boxAttrs) +val checkbox : formTag bool [] ([Checked = bool, Onchange = transaction unit] ++ boxAttrs) type file val fileName : file -> option string @@ -1003,18 +1008,19 @@ val label : bodyTag ([For = id, Accesskey = string] ++ tableAttrs) con cformTag = fn (attrs :: {Type}) (inner :: {Unit}) => ctx ::: {Unit} - -> [[Body] ~ ctx] => - unit -> tag attrs ([Body] ++ ctx) inner [] [] + -> [[Body] ~ ctx] => [[Body] ~ inner] => + unit -> tag attrs ([Body] ++ ctx) ([Body] ++ inner) [] [] val ctextbox : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs) [] +val cpassword : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, + Ontext = transaction unit] ++ boxAttrs) [] val button : cformTag ([Value = string] ++ boxAttrs) [] -val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool] ++ boxAttrs) [] +val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs) [] -con cselect = [Cselect] -val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) cselect -val coption : unit -> tag [Value = string, Selected = bool] cselect [] [] [] +val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect] +val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] [] val ctextarea : cformTag ([Value = string, Rows = int, Cols = int, Source = source string, Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs) [] diff --git a/lib/ur/string.ur b/lib/ur/string.ur index 59a8e5c5..da4e7eb4 100644 --- a/lib/ur/string.ur +++ b/lib/ur/string.ur @@ -86,3 +86,28 @@ fun newlines [ctx] [[Body] ~ ctx] (s : string) : xml ([Body] ++ ctx) [] [] = fun isPrefix {Full = f, Prefix = p} = length f >= length p && substring f {Start = 0, Len = length p} = p + +fun trim s = + let + val len = length s + + fun findStart i = + if i < len && isspace (sub s i) then + findStart (i+1) + else + i + + fun findFinish i = + if i >= 0 && isspace (sub s i) then + findFinish (i-1) + else + i + + val start = findStart 0 + val finish = findFinish (len - 1) + in + if finish >= start then + substring s {Start = start, Len = finish - start + 1} + else + "" + end diff --git a/lib/ur/string.urs b/lib/ur/string.urs index 0861279d..1bdca96c 100644 --- a/lib/ur/string.urs +++ b/lib/ur/string.urs @@ -33,3 +33,5 @@ val mp : (char -> char) -> string -> string val newlines : ctx ::: {Unit} -> [[Body] ~ ctx] => string -> xml ([Body] ++ ctx) [] [] val isPrefix : {Full : t, Prefix : t} -> bool + +val trim : t -> t diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 5b9d43ab..3250a5a3 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -405,3 +405,8 @@ fun postFields pb = "application/x-www-form-urlencoded" => postFields' (postData pb) | _ => error <xml>Tried to get POST fields, but MIME type is not "application/x-www-form-urlencoded"</xml> end + +fun max [t] ( _ : ord t) (x : t) (y : t) : t = + if x > y then x else y +fun min [t] ( _ : ord t) (x : t) (y : t) : t = + if x < y then x else y diff --git a/lib/ur/top.urs b/lib/ur/top.urs index 2ea86dc4..15bc6a22 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -287,3 +287,6 @@ val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} val mkRead' : t ::: Type -> (string -> option t) -> string -> read t val postFields : postBody -> list (string * string) + +val max : t ::: Type -> ord t -> t -> t -> t +val min : t ::: Type -> ord t -> t -> t -> t 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))) diff --git a/tests/DynChannel.ur b/tests/DynChannel.ur new file mode 100644 index 00000000..d3688781 --- /dev/null +++ b/tests/DynChannel.ur @@ -0,0 +1,29 @@ +table channels : {Id : int, Channel:channel xbody} + +fun dosend (s:string) : transaction unit = + c <- oneRow1 (SELECT * FROM channels); + debug ("Sending " ^ s ^ " through the channel..."); + send c.Channel <xml>{[s]}</xml> + +fun mkchannel {} : transaction xbody = + c <- channel; + s <- source <xml/>; + dml( DELETE FROM channels WHERE Id >= 0); + dml( INSERT INTO channels(Id, Channel) VALUES(0, {[c]}) ); + return <xml> + <button value="Send" onclick={fn _ => rpc(dosend "blabla")}/> + <active code={spawn(x <- recv c; alert ("Got something from the channel"); set s x); return <xml/>}/> + <dyn signal={signal s}/> + </xml> + +fun main {} : transaction page = + s <- source <xml/>; + return <xml> + <head/> + <body> + <button value="Register" onclick={fn _ => + x <- rpc(mkchannel {}); set s x + }/> + <dyn signal={signal s}/> + </body> + </xml> diff --git a/tests/DynChannel.urp b/tests/DynChannel.urp new file mode 100644 index 00000000..08d6d1a5 --- /dev/null +++ b/tests/DynChannel.urp @@ -0,0 +1,6 @@ +database dbname=DynChannel.db +sql DynChannel.sql +debug + +$/list +DynChannel diff --git a/tests/button.ur b/tests/button.ur new file mode 100644 index 00000000..febcb0c9 --- /dev/null +++ b/tests/button.ur @@ -0,0 +1,4 @@ +fun main () : transaction page = return <xml><body> + <button onclick={fn _ => alert "AHOY"}><b>CLICK IT</b></button> +</body></xml> + diff --git a/tests/data_attr.ur b/tests/data_attr.ur index 80dda857..4462dc10 100644 --- a/tests/data_attr.ur +++ b/tests/data_attr.ur @@ -1,5 +1,5 @@ fun dynd r = return <xml><body> - <div data={data_attr r.Attr r.Value}>How about that?</div> + <div data={data_attr data_kind r.Attr r.Value}>How about that?</div> </body></xml> fun main () : transaction page = @@ -7,7 +7,7 @@ fun main () : transaction page = a <- source ""; v <- source ""; return <xml><body> - <div data-foo="hi" data-bar="bye" data-baz="why">Whoa there, cowboy!</div> + <div data-foo="hi" aria-something="wow" data-bar="bye" data-baz="why">Whoa there, cowboy!</div> <hr/> @@ -20,7 +20,7 @@ fun main () : transaction page = <ctextbox source={a}/> = <ctextbox source={v}/> <button onclick={fn _ => - a <- get a; v <- get v; set s <xml><div data={data_attr a v}>OHO!</div></xml>}/> + a <- get a; v <- get v; set s <xml><div data={data_attr data_kind a v}>OHO!</div></xml>}/> <hr/> <dyn signal={signal s}/> </body></xml> diff --git a/tests/dbupload2.sh b/tests/dbupload2.sh new file mode 100755 index 00000000..cecf1960 --- /dev/null +++ b/tests/dbupload2.sh @@ -0,0 +1,17 @@ +#!/bin/sh + +set -e + +cd `dirname $0` + +urweb -dbms sqlite dbupload2 + +rm -rf dbupload2.db || true +sqlite3 dbupload2.db < dbupload2.sql + +./dbupload2.exe -p 8083 & +sleep 1 + +touch /tmp/empty +curl --verbose -F"operation=upload" -F"filename=@/tmp/empty" http://localhost:8083/Blabla/bla + diff --git a/tests/dbupload2.ur b/tests/dbupload2.ur new file mode 100644 index 00000000..428f2460 --- /dev/null +++ b/tests/dbupload2.ur @@ -0,0 +1,29 @@ +table t : { Id : int, Blob : blob, MimeType : string } +sequence s + +fun getImage id : transaction page = + r <- oneRow1 (SELECT t.Blob, t.MimeType + FROM t + WHERE t.Id = {[id]}); + returnBlob r.Blob (blessMime r.MimeType) + +fun handle (r : {File:file, Param:string}) = + id <- nextval s; + dml (INSERT INTO t (Id, Blob, MimeType) + VALUES ({[id]}, {[fileData r.File]}, {[fileMimeType r.File]})); + debug ("Text is " ^ r.Param); + main () + +and main () : transaction page = + x <- queryX1 (SELECT t.Id FROM t) + (fn r => <xml><img src={url (getImage r.Id)}/> +</xml>); + return <xml><body> + <form> + <upload{#File}/> + <textbox{#Param} value="text"/> + <submit action={handle}/> + </form> + <hr/> + {x} + </body></xml> diff --git a/tests/dbupload2.urp b/tests/dbupload2.urp new file mode 100644 index 00000000..bd550589 --- /dev/null +++ b/tests/dbupload2.urp @@ -0,0 +1,7 @@ +database dbname=dbupload2.db +sql dbupload2.sql +allow mime * +rewrite all Dbupload2/* +debug + +dbupload2 diff --git a/tests/dbupload2.urs b/tests/dbupload2.urs new file mode 100644 index 00000000..80240dee --- /dev/null +++ b/tests/dbupload2.urs @@ -0,0 +1 @@ +val main: {} -> transaction page diff --git a/tests/empty_record.ur b/tests/empty_record.ur new file mode 100644 index 00000000..45ab6fdb --- /dev/null +++ b/tests/empty_record.ur @@ -0,0 +1,3 @@ +val concatX [ctx ::: {Unit}] [use ::: {Type}] + : list (xml ctx use []) -> xml ctx use [] + = List.foldl join <xml/> diff --git a/tests/empty_record.urp b/tests/empty_record.urp new file mode 100644 index 00000000..c81175fc --- /dev/null +++ b/tests/empty_record.urp @@ -0,0 +1,2 @@ +$/list +empty_record diff --git a/tests/files.ur b/tests/files.ur new file mode 100644 index 00000000..94cf8eb1 --- /dev/null +++ b/tests/files.ur @@ -0,0 +1 @@ +fun main () : transaction page = return <xml>Main page</xml> diff --git a/tests/files.urp b/tests/files.urp new file mode 100644 index 00000000..100992e5 --- /dev/null +++ b/tests/files.urp @@ -0,0 +1,6 @@ +rewrite all Files/* +file /hello_world.txt hello.txt +file /img/web.png web.png +file /files.urp files.urp + +files diff --git a/tests/hello.txt b/tests/hello.txt new file mode 100644 index 00000000..980a0d5f --- /dev/null +++ b/tests/hello.txt @@ -0,0 +1 @@ +Hello World! diff --git a/tests/lessSafeFfi.ur b/tests/lessSafeFfi.ur index da79bfdc..6bf26ba9 100644 --- a/tests/lessSafeFfi.ur +++ b/tests/lessSafeFfi.ur @@ -1,15 +1,18 @@ ffi foo : int -> int ffi bar serverOnly benignEffectful : int -> transaction unit ffi baz : transaction int +ffi adder : int -> int -> int -ffi bup jsFunc "jsbup" : int -> transaction unit +ffi bup jsFunc "alert" : string -> transaction unit +ffi alert : string -> transaction unit fun other () : transaction page = (*bar 17; q <- baz;*) return <xml><body> (*{[foo 42]}, {[q]}*) - <button onclick={fn _ => bup 32}/> + <button value="bup" onclick={fn _ => bup "asdf"}/> + <button value="alert" onclick={fn _ => alert "qqqz"}/> </body></xml> fun main () = return <xml><body> diff --git a/tests/letwhere.ur b/tests/letwhere.ur new file mode 100644 index 00000000..8854f2aa --- /dev/null +++ b/tests/letwhere.ur @@ -0,0 +1,7 @@ +fun main () : transaction page = + let + return <xml>Hi {[alice]} and {[bob]}!</xml> + where + val alice = "Alice" + val bob = "Bob" + end diff --git a/tests/pb.ur b/tests/pb.ur new file mode 100644 index 00000000..e6e5bd5c --- /dev/null +++ b/tests/pb.ur @@ -0,0 +1,7 @@ +fun api_1 (pb:postBody) (nm:string) : transaction page = + return <xml>Processing the request</xml> + +fun api (pb:postBody) (v:int) (nm:string) : transaction page = + case v of + 1 => api_1 pb nm + | _ => error <xml>Version {[v]} is not supported</xml> diff --git a/tests/pb.urs b/tests/pb.urs new file mode 100644 index 00000000..9def0871 --- /dev/null +++ b/tests/pb.urs @@ -0,0 +1 @@ +val api : postBody -> int -> string -> transaction page diff --git a/tests/rpchan.ur b/tests/rpchan.ur new file mode 100644 index 00000000..08308d90 --- /dev/null +++ b/tests/rpchan.ur @@ -0,0 +1,18 @@ +fun remote () = + ch <- channel; + send ch "Hello World!"; + return ch + +fun remoter () = + ch <- channel; + send ch "Hello World!"; + return <xml><active code={spawn (s <- recv ch; alert s); return <xml/>}/></xml> + +fun main () = + x <- source <xml/>; + return <xml><body> + <button onclick={fn _ => ch <- rpc (remote ()); s <- recv ch; alert s}>TEST</button> + <button onclick={fn _ => y <- rpc (remoter ()); set x y}>TESTER</button> + <hr/> + <dyn signal={signal x}/> + </body></xml> diff --git a/tests/rpchan.urs b/tests/rpchan.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/rpchan.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/sqlurl.ur b/tests/sqlurl.ur new file mode 100644 index 00000000..cdd51ca8 --- /dev/null +++ b/tests/sqlurl.ur @@ -0,0 +1,4 @@ +table t : { Url : url } + +task initialize = fn () => + dml (INSERT INTO t (Url) VALUES ({[bless "http://www.google.com/"]})) diff --git a/tests/sqlurl.urp b/tests/sqlurl.urp new file mode 100644 index 00000000..bb5544df --- /dev/null +++ b/tests/sqlurl.urp @@ -0,0 +1,6 @@ +database dbname=test +sql sqlurl.sql +rewrite url Sqlurl/* +allow url http://www.google.com/ + +sqlurl diff --git a/tests/tags.ur b/tests/tags.ur new file mode 100644 index 00000000..059e869a --- /dev/null +++ b/tests/tags.ur @@ -0,0 +1,26 @@ +table images : { Id : int, Content : blob } +table tags : { Id : int, Tag : string } + +datatype mode = Present | Absent +type condition = { Tag : string, Mode : mode } + +type tag_query = sql_query [] [] [] [Id = int] + +fun addCondition (c : condition) (q : tag_query) : tag_query = + case c.Mode of + Present => (SELECT I.Id AS Id + FROM ({{q}}) AS I + JOIN tags ON tags.Id = I.Id AND tags.Tag = {[c.Tag]}) + | Absent => (SELECT I.Id AS Id + FROM ({{q}}) AS I + LEFT JOIN tags ON tags.Id = I.Id AND tags.Tag = {[c.Tag]} + WHERE tags.Tag IS NULL) + +fun withConditions (cs : list condition) : tag_query = + List.foldl addCondition (SELECT images.Id AS Id FROM images) cs + +fun main (cs : list condition) : transaction page = + x <- queryX (withConditions cs) (fn r => <xml><li>{[r.Id]}</li></xml>); + return <xml><body> + {x} + </body></xml> diff --git a/tests/tags.urp b/tests/tags.urp new file mode 100644 index 00000000..b2f21c5a --- /dev/null +++ b/tests/tags.urp @@ -0,0 +1,6 @@ +database dbname=test +sql tags.sql +rewrite url Tags/* + +$/list +tags diff --git a/tests/wackyunif.ur b/tests/wackyunif.ur new file mode 100644 index 00000000..2a215e69 --- /dev/null +++ b/tests/wackyunif.ur @@ -0,0 +1,2 @@ +val concatX [ctx] [use] : _ -> _ ctx use _ = + List.foldl join <xml/> diff --git a/tests/wackyunif.urp b/tests/wackyunif.urp new file mode 100644 index 00000000..35791acf --- /dev/null +++ b/tests/wackyunif.urp @@ -0,0 +1,2 @@ +$/list +wackyunif diff --git a/tests/web.png b/tests/web.png Binary files differnew file mode 100644 index 00000000..17548060 --- /dev/null +++ b/tests/web.png |
