summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2014-05-27 21:38:01 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2014-05-27 21:38:01 -0400
commitdc336268adfbf2b05b34ab006de5990f8ce9086c (patch)
tree22fb72ef5ad32f47571fa250515108188d7e22f9
parentd941d873c0203009ccf44aa4aed97671703ca375 (diff)
parent4cee29f03879d25963e3d8a8dda879e0a007033c (diff)
Merge.
-rw-r--r--CHANGELOG14
-rw-r--r--configure.ac2
-rw-r--r--doc/manual.tex44
-rw-r--r--include/urweb/request.h11
-rw-r--r--include/urweb/types_cpp.h6
-rw-r--r--include/urweb/urweb_cpp.h10
-rw-r--r--lib/js/urweb.js47
-rw-r--r--lib/ur/basis.urs81
-rw-r--r--lib/ur/top.urs4
-rw-r--r--src/c/cgi.c6
-rw-r--r--src/c/fastcgi.c13
-rw-r--r--src/c/http.c14
-rw-r--r--src/c/request.c40
-rw-r--r--src/c/static.c6
-rw-r--r--src/c/urweb.c117
-rw-r--r--src/compiler.sml1
-rw-r--r--src/corify.sml75
-rw-r--r--src/elab.sml3
-rw-r--r--src/elab_env.sml1
-rw-r--r--src/elab_err.sig1
-rw-r--r--src/elab_err.sml4
-rw-r--r--src/elab_print.sml1
-rw-r--r--src/elab_util.sml8
-rw-r--r--src/elaborate.sml22
-rw-r--r--src/elisp/urweb-mode.el2
-rw-r--r--src/expl.sml1
-rw-r--r--src/expl_env.sml1
-rw-r--r--src/expl_print.sml1
-rw-r--r--src/expl_rename.sml10
-rw-r--r--src/explify.sml1
-rw-r--r--src/jscomp.sig4
-rw-r--r--src/jscomp.sml12
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/mono_opt.sml10
-rw-r--r--src/monoize.sml71
-rw-r--r--src/settings.sig7
-rw-r--r--src/settings.sml9
-rw-r--r--src/source.sml10
-rw-r--r--src/source_print.sml23
-rw-r--r--src/unnest.sml1
-rw-r--r--src/urweb.grm235
-rw-r--r--src/urweb.lex1
-rw-r--r--tests/activeEmpty.ur5
-rw-r--r--tests/bindpat.ur6
-rw-r--r--tests/data_attr.ur26
-rw-r--r--tests/data_attr.urs1
-rw-r--r--tests/dynClass.ur2
-rw-r--r--tests/dynList.ur22
-rw-r--r--tests/dynList.urp4
-rw-r--r--tests/dynList.urs1
-rw-r--r--tests/lessSafeFfi.ur19
-rw-r--r--tests/lessSafeFfi.urp5
-rw-r--r--tests/lessSafeFfi.urs1
-rw-r--r--tests/thead.ur16
54 files changed, 819 insertions, 222 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 7d5d1b6c..c474049a 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,18 @@
========
+20140426
+========
+
+- New Basis functions having to do with dates and times, wrapped nicely in new
+ Datetime module of standard library
+- New .urp directives: 'html5', 'neverInline', 'noMangleSql'
+- New command-line arguments: '-explainEmbed', '-stop'
+- Changes to C FFI interface, especially for uw_register_transactional()
+- 'Basis.getEnv' now always calls UNIX getenv() outside a page handler.
+- Changed <active> to avoid generating an empty <span> for empty content.
+- New HTML tag: <pre>
+- Bug fixes and improvements to type inference, optimizations, and documentation
+
+========
20131231
========
diff --git a/configure.ac b/configure.ac
index 795e46a6..78b913ea 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-AC_INIT([urweb], [20131231])
+AC_INIT([urweb], [20140426])
WORKING_VERSION=1
AC_USE_SYSTEM_EXTENSIONS
diff --git a/doc/manual.tex b/doc/manual.tex
index 457df39b..7fd135fa 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -62,6 +62,8 @@ Some other packages must be installed for the above to work. At a minimum, you
apt-get install mlton libssl-dev
\end{verbatim}
+Note that, like the Ur/Web compiler, MLton is a whole-program optimizing compiler, so it frequently requires much more memory than old-fashioned compilers do. Expect building Ur/Web with MLton to require not much less than a gigabyte of RAM. If a \texttt{mlton} invocation ends suspiciously, the most likely explanation is that it has exhausted available memory.
+
To build programs that access SQL databases, you also need one of these client libraries for supported backends.
\begin{verbatim}
apt-get install libpq-dev libmysqlclient-dev libsqlite3-dev
@@ -72,7 +74,7 @@ It is also possible to access the modules of the Ur/Web compiler interactively,
apt-get install smlnj libsmlnj-smlnj ml-yacc ml-lpt
\end{verbatim}
-To begin an interactive session with the Ur compiler modules, run \texttt{make smlnj}, and then, from within an \texttt{sml} session, run \texttt{CM.make "src/urweb.cm";}. The \texttt{Compiler} module is the main entry point.
+To begin an interactive session with the Ur compiler modules, run \texttt{make smlnj}, and then, from within an \texttt{sml} session, run \texttt{CM.make "src/urweb.cm";}. The \texttt{Compiler} module is the main entry point, and you can find its signature in \texttt{src/compiler.sig}.
To run an SQL-backed application with a backend besides SQLite, you will probably want to install one of these servers.
@@ -266,6 +268,8 @@ sqlite3 path/to/database/file <app.sql
\item \texttt{-dumpSource}: When compilation fails, output to stderr the complete source code of the last intermediate program before the compilation phase that signaled the error. (Warning: these outputs can be very long and aren't especially optimized for readability!)
+\item \texttt{-explainEmbed}: Trigger more verbose error messages about inability to embed server-side values in client-side code.
+
\item \texttt{-limit class num}: Equivalent to the \texttt{limit} directive from \texttt{.urp} files
\item \texttt{-moduleOf FILENAME}: Prints the Ur/Web module name corresponding to source file \texttt{FILENAME}, exiting immediately afterward.
@@ -1440,6 +1444,8 @@ $$\begin{array}{l}
The Ur/Web compiler provides syntactic sugar for monads, similar to Haskell's \cd{do} notation. An expression $x \leftarrow e_1; e_2$ is desugared to $\mt{bind} \; e_1 \; (\lambda x \Rightarrow e_2)$, and an expression $e_1; e_2$ is desugared to $\mt{bind} \; e_1 \; (\lambda () \Rightarrow e_2)$. Note a difference from Haskell: as the $e_1; e_2$ case desugaring involves a function with $()$ as its formal argument, the type of $e_1$ must be of the form $m \; \{\}$, rather than some arbitrary $m \; t$.
+The syntactic sugar also allows $p \leftarrow e_1; e_2$ for $p$ a pattern. The pattern should be guaranteed to match any value of the corresponding type, or there will be a compile-time error.
+
\subsection{Transactions}
Ur is a pure language; we use Haskell's trick to support controlled side effects. The standard library defines a monad $\mt{transaction}$, meant to stand for actions that may be undone cleanly. By design, no other kinds of actions are supported.
@@ -2050,7 +2056,9 @@ $$\begin{array}{l}
\hspace{.1in} \Rightarrow \mt{xml} \; \mt{ctx} \; \mt{use_1} \; \mt{bind} \to \mt{xml} \; \mt{ctx} \; (\mt{use_1} \rc \mt{use_2}) \; \mt{bind}
\end{array}$$
-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. It \emph{is} possible to add new tags directly to \texttt{basis.urs}, but this should only be done as a prelude to suggesting a patch to the main distribution.
+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.
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}
@@ -2394,7 +2402,7 @@ The currently supported task kinds are:
\end{itemize}
-\section{The Foreign Function Interface}
+\section{\label{ffi}The Foreign Function Interface}
It is possible to call your own C and JavaScript code from Ur/Web applications, via the foreign function interface (FFI). The starting point for a new binding is a \texttt{.urs} signature file that presents your external library as a single Ur/Web module (with no nested modules). Compilation conventions map the types and values that you use into C and/or JavaScript types and values.
@@ -2457,12 +2465,12 @@ void *uw_malloc(uw_context, size_t);
\item \begin{verbatim}
typedef void (*uw_callback)(void *);
typedef void (*uw_callback_with_retry)(void *, int will_retry);
-void uw_register_transactional(uw_context, void *data, uw_callback commit,
- uw_callback rollback, uw_callback_with_retry free);
+int uw_register_transactional(uw_context, void *data, uw_callback commit,
+ uw_callback rollback, uw_callback_with_retry free);
\end{verbatim}
- All side effects in Ur/Web programs need to be compatible with transactions, such that any set of actions can be undone at any time. Thus, you should not perform actions with non-local side effects directly; instead, register handlers to be called when the current transaction is committed or rolled back. The arguments here give an arbitary piece of data to be passed to callbacks, a function to call on commit, a function to call on rollback, and a function to call afterward in either case to clean up any allocated resources. A rollback handler may be called after the associated commit handler has already been called, if some later part of the commit process fails. A free handler is told whether the runtime system expects to retry the current page request after rollback finishes.
+ All side effects in Ur/Web programs need to be compatible with transactions, such that any set of actions can be undone at any time. Thus, you should not perform actions with non-local side effects directly; instead, register handlers to be called when the current transaction is committed or rolled back. The arguments here give an arbitary piece of data to be passed to callbacks, a function to call on commit, a function to call on rollback, and a function to call afterward in either case to clean up any allocated resources. A rollback handler may be called after the associated commit handler has already been called, if some later part of the commit process fails. A free handler is told whether the runtime system expects to retry the current page request after rollback finishes. The return value of \texttt{uw\_register\_transactional()} is 0 on success and nonzero on failure (where failure currently only happens when exceeding configured limits on number of transactionals).
- Any of the callbacks may be \texttt{NULL}. To accommodate some stubbornly non-transactional real-world actions like sending an e-mail message, Ur/Web treats \texttt{NULL} \texttt{rollback} callbacks specially. When a transaction commits, all \texttt{commit} actions that have non-\texttt{NULL} rollback actions are tried before any \texttt{commit} actions that have \texttt{NULL} rollback actions. Thus, if a single execution uses only one non-transactional action, and if that action never fails partway through its execution while still causing an observable side effect, then Ur/Web can maintain the transactional abstraction.
+ Any of the callbacks may be \texttt{NULL}. To accommodate some stubbornly non-transactional real-world actions like sending an e-mail message, Ur/Web treats \texttt{NULL} \texttt{rollback} callbacks specially. When a transaction commits, all \texttt{commit} actions that have non-\texttt{NULL} rollback actions are tried before any \texttt{commit} actions that have \texttt{NULL} rollback actions. Furthermore, an SQL \texttt{COMMIT} is also attempted in between the two phases, so the nicely transactional actions have a chance to influence whether data are committed to the database, while \texttt{NULL}-rollback actions only get run in the first place after committing data. The reason for all this is that it is \emph{expected} that concurrency interactions will cause database commits to fail in benign ways that call for transaction restart. A truly non-undoable action should only be run after we are sure the database transaction will commit.
When a request handler ends with multiple pending transactional actions, their handlers are run in a first-in-last-out stack-like order, wherever the order would otherwise be ambiguous.
@@ -2486,12 +2494,12 @@ In contrast to C FFI code, JavaScript FFI functions take no extra context argume
\begin{itemize}
\item Integers, floats, strings, characters, and booleans are represented in the usual JavaScript way.
-\item Ur functions are represented in an unspecified way. This means that you should not rely on any details of function representation. Named FFI functions are represented as JavaScript functions with as many arguments as their Ur types specify. To call a non-FFI function \texttt{f} on argument \texttt{x}, run \texttt{execF(f, x)}. To lift a normal JavaScript function \cd{f} into an Ur/Web JavaScript function, run \cd{flift(f)}.
+\item Ur functions are represented in an unspecified way. This means that you should not rely on any details of function representation. Named FFI functions are represented as JavaScript functions with as many arguments as their Ur types specify. To call a non-FFI function \texttt{f} on argument \texttt{x}, run \texttt{execF(f, x)}. A normal JavaScript function may also be used in a position where the Ur/Web runtime system expects an Ur/Web function.
\item An Ur record is represented with a JavaScript record, where Ur field name \texttt{N} translates to JavaScript field name \texttt{\_N}. An exception to this rule is that the empty record is encoded as \texttt{null}.
\item \texttt{option}-like types receive special handling similar to their handling in C. The ``\texttt{None}'' constructor is \texttt{null}, and a use of the ``\texttt{Some}'' constructor on a value \texttt{v} is either \texttt{v}, if the underlying type doesn't need to use \texttt{null}; or \texttt{\{v:v\}} otherwise.
\item Any other datatypes represent a non-value-carrying constructor \texttt{C} as \texttt{"C"} and an application of a constructor \texttt{C} to value \texttt{v} as \texttt{\{n:"C", v:v\}}. This rule only applies to datatypes defined in FFI module signatures; the compiler is free to optimize the representations of other, non-\texttt{option}-like datatypes in arbitrary ways.
\item As in the C FFI, all abstract types of program syntax are implemented with strings in JavaScript.
-\item A value of Ur type \texttt{transaction t} is represented in the same way as for \texttt{unit -> t}.
+\item A value of Ur type \texttt{transaction t} is represented in the same way as for \texttt{unit -> t}. (Note that FFI functions skip this extra level of function encoding, which only applies to functions defined in Ur/Web.)
\end{itemize}
It is possible to write JavaScript FFI code that interacts with the functional-reactive structure of a document. Here is a quick summary of some of the simpler functions to use; descriptions of fancier stuff may be added later on request (and such stuff should be considered ``undocumented features'' until then).
@@ -2524,6 +2532,24 @@ FFI modules may introduce new tags as values with $\mt{Basis.tag}$ types. See \
The onus is on the coder of a new tag's interface to think about consequences for code injection attacks, messing with the DOM in ways that may break Ur/Web reactive programming, etc.
+\subsection{The Less Safe FFI}
+
+An alternative interface is provided for declaring FFI functions inline within normal Ur/Web modules. This facility must be opted into with the \texttt{lessSafeFfi} \texttt{.urp} directive, since it breaks a crucial property, allowing code in a \texttt{.ur} file to break basic invariants of the Ur/Web type system. Without this option, one only needs to audit \texttt{.urp} files to be sure an application obeys the type-system rules. The alternative interface may be more convenient for such purposes as declaring an FFI function typed in terms of some type local to a module.
+
+When the less safe mode is enabled, declarations like this one are accepted, at the top level of a \texttt{.ur} file:
+\begin{verbatim}
+ ffi foo : int -> int
+\end{verbatim}
+
+Now \texttt{foo} is available as a normal function. If called in server-side code, and if the above declaration appeared in \texttt{bar.ur}, the C function will be linked as \texttt{uw\_Bar\_foo()}. It is also possible to declare an FFI function to be implemented in JavaScript, using a general facility for including modifiers in an FFI declaration. The modifiers appear before the colon, separated by spaces. Here are the available ones, which have the same semantics as corresponding \texttt{.urp} directives.
+\begin{itemize}
+\item \texttt{effectful}
+\item \texttt{benignEffectful}
+\item \texttt{clientOnly}
+\item \texttt{serverOnly}
+\item \texttt{jsFunc "putJsFuncNameHere"}
+\end{itemize}
+
\section{Compiler Phases}
diff --git a/include/urweb/request.h b/include/urweb/request.h
index a1a7d78d..0b19e7f4 100644
--- a/include/urweb/request.h
+++ b/include/urweb/request.h
@@ -7,13 +7,13 @@
typedef struct uw_rc *uw_request_context;
-void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug);
+void uw_request_init(uw_app *app, uw_loggers* ls);
void uw_sign(const char *in, char *out);
uw_request_context uw_new_request_context(void);
void uw_free_request_context(uw_request_context);
-request_result uw_request(uw_request_context, uw_context,
+request_result uw_request(uw_request_context rc, uw_context ctx,
char *method, char *path, char *query_string,
char *body, size_t body_len,
void (*on_success)(uw_context), void (*on_failure)(uw_context),
@@ -22,13 +22,12 @@ request_result uw_request(uw_request_context, uw_context,
int (*send)(int sockfd, const void *buf, ssize_t len),
int (*close)(int fd));
-uw_context uw_request_new_context(int id, uw_app*, void *logger_data, uw_logger log_error, uw_logger log_debug);
+uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls);
typedef struct {
uw_app *app;
- void *logger_data;
- uw_logger log_error, log_debug;
-} loggers;
+ uw_loggers *loggers;
+} pruner_data;
void *client_pruner(void *data);
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index cd80b0e7..0c431ff8 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -106,6 +106,12 @@ typedef struct {
int is_html5;
} uw_app;
+typedef struct {
+ /* uw_app *app; */
+ void *logger_data;
+ uw_logger log_error, log_debug;
+} uw_loggers;
+
#define ERROR_BUF_LEN 1024
typedef struct {
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 799d0861..ea733c8c 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -14,13 +14,13 @@ void uw_global_init(void);
void uw_app_init(uw_app*);
void uw_client_connect(unsigned id, int pass, int sock,
- int (*send)(int sockfd, const void *buf, size_t len),
+ int (*send)(int sockfd, const void *buf, ssize_t len),
int (*close)(int fd),
void *logger_data, uw_logger log_error);
void uw_prune_clients(struct uw_context *);
failure_kind uw_initialize(struct uw_context *);
-struct uw_context * uw_init(int id, void *logger_data, uw_logger log_debug);
+struct uw_context * uw_init(int id, uw_loggers *lg);
void uw_close(struct uw_context *);
int uw_set_app(struct uw_context *, uw_app*);
uw_app *uw_get_app(struct uw_context *);
@@ -36,6 +36,8 @@ failure_kind uw_begin_init(struct uw_context *);
void uw_set_on_success(char *);
void uw_set_headers(struct uw_context *, char *(*get_header)(void *, const char *), void *get_header_data);
void uw_set_env(struct uw_context *, char *(*get_env)(void *, const char *), void *get_env_data);
+uw_loggers* uw_get_loggers(struct uw_context *ctx);
+uw_loggers* uw_get_loggers(struct uw_context *ctx);
failure_kind uw_begin(struct uw_context *, char *path);
void uw_ensure_transaction(struct uw_context *);
failure_kind uw_begin_onError(struct uw_context *, char *msg);
@@ -282,7 +284,7 @@ uw_Basis_int uw_Basis_datetimeSecond(struct uw_context *, uw_Basis_time);
uw_Basis_int uw_Basis_datetimeDayOfWeek(struct uw_context *, uw_Basis_time);
extern const uw_Basis_time uw_Basis_minTime;
-void uw_register_transactional(struct uw_context *, void *data, uw_callback commit, uw_callback rollback, uw_callback_with_retry free);
+int uw_register_transactional(struct uw_context *, void *data, uw_callback commit, uw_callback rollback, uw_callback_with_retry free);
void uw_check_heap(struct uw_context *, size_t extra);
char *uw_heap_front(struct uw_context *);
@@ -389,6 +391,8 @@ uw_Basis_string uw_Basis_fieldValue(struct uw_context *, uw_Basis_postField);
uw_Basis_string uw_Basis_remainingFields(struct uw_context *, uw_Basis_postField);
uw_Basis_postField *uw_Basis_firstFormField(struct uw_context *, uw_Basis_string);
+uw_Basis_string uw_Basis_blessData(struct uw_context *, uw_Basis_string);
+
extern const char uw_begin_xhtml[], uw_begin_html5[];
#endif
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 2e350378..c3cab50a 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1009,8 +1009,6 @@ function active(s) {
if (suspendScripts)
return;
- var span = document.createElement("span");
- addNode(span);
var ms = maySuspend;
maySuspend = false;
try {
@@ -1020,7 +1018,11 @@ function active(s) {
throw e;
}
maySuspend = ms;
- setInnerHTML(span, html);
+ if (html != "") {
+ var span = document.createElement("span");
+ addNode(span);
+ setInnerHTML(span, html);
+ }
}
function input(x, s, recreate, type, name) {
@@ -1111,7 +1113,7 @@ function tbx(s) {
return x;
}
-function dynClass(html, s_class, s_style) {
+function dynClass(pnode, html, s_class, s_style) {
if (suspendScripts)
return;
@@ -1119,7 +1121,7 @@ function dynClass(html, s_class, s_style) {
html = flatten(htmlCls, html);
htmlCls = htmlCls.v;
- var dummy = document.createElement("body");
+ var dummy = document.createElement(pnode);
suspendScripts = true;
dummy.innerHTML = html;
suspendScripts = false;
@@ -1150,23 +1152,23 @@ function dynClass(html, s_class, s_style) {
if (s_style) {
var htmlCls2 = s_class ? null : htmlCls;
- var x = document.createElement("script");
- x.dead = false;
- x.signal = s_style;
- x.sources = null;
- x.closures = htmlCls2;
-
- x.recreate = function(v) {
- for (var ls = x.closures; ls != htmlCls2; ls = ls.next)
+ var y = document.createElement("script");
+ y.dead = false;
+ y.signal = s_style;
+ y.sources = null;
+ y.closures = htmlCls2;
+
+ y.recreate = function(v) {
+ for (var ls = y.closures; ls != htmlCls2; ls = ls.next)
freeClosure(ls.data);
var cls = {v : null};
html.style.cssText = flatten(cls, v);
- x.closures = concat(cls.v, htmlCls2);
+ y.closures = concat(cls.v, htmlCls2);
}
- html.appendChild(x);
- populate(x);
+ html.appendChild(y);
+ populate(y);
}
}
@@ -1940,6 +1942,19 @@ function bless(s) {
}
+// Attribute name blessing
+
+function blessData(s) {
+ for (var i = 0; i < s.length; ++i) {
+ var c = s[i];
+ if (!isAlnum(c) && c != '-' && c != '_')
+ er("Disallowed character in data-* attribute name");
+ }
+
+ return s;
+}
+
+
// CSS validation
function atom(s) {
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index c94f2ba6..ce864563 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -796,11 +796,17 @@ val active : unit
val script : unit
-> tag [Code = transaction unit] head [] [] []
-val head : unit -> tag [] html head [] []
-val title : unit -> tag [] head [] [] []
-val link : unit -> tag [Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] []
+(* Type for HTML5 "data-*" attributes. *)
+type data_attr
+val data_attr : 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
-val body : unit -> tag [Onload = transaction unit, Onresize = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit]
+val head : unit -> tag [Data = data_attr] html head [] []
+val title : unit -> tag [Data = data_attr] head [] [] []
+val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] []
+
+val body : unit -> tag [Data = data_attr, Onload = transaction unit, Onresize = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit]
html body [] []
con bodyTag = fn (attrs :: {Type}) =>
ctx ::: {Unit} ->
@@ -811,7 +817,7 @@ con bodyTagStandalone = fn (attrs :: {Type}) =>
-> [[Body] ~ ctx] =>
unit -> tag attrs ([Body] ++ ctx) [] [] []
-val br : bodyTagStandalone [Id = id]
+val br : bodyTagStandalone [Data = data_attr, Id = id]
con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit]
@@ -837,8 +843,8 @@ con scrollEvents = [Onscroll = transaction unit]
con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents
con tableEvents = focusEvents ++ mouseEvents ++ keyEvents
-con boxAttrs = [Id = id, Title = string] ++ boxEvents
-con tableAttrs = [Id = id, Title = string] ++ tableEvents
+con boxAttrs = [Data = data_attr, Id = id, Title = string] ++ boxEvents
+con tableAttrs = [Data = data_attr, Id = id, Title = string] ++ tableEvents
val span : bodyTag boxAttrs
val div : bodyTag boxAttrs
@@ -865,6 +871,44 @@ val ul : bodyTag boxAttrs
val hr : bodyTag boxAttrs
+val pre : bodyTag boxAttrs
+
+(** sections **)
+val section : bodyTag boxAttrs
+val article : bodyTag boxAttrs
+val nav : bodyTag boxAttrs
+val aside : bodyTag boxAttrs
+val footer : bodyTag boxAttrs
+val header : bodyTag boxAttrs
+val main : bodyTag boxAttrs
+
+(** forms **)
+val meter : bodyTag boxAttrs
+val progress : bodyTag boxAttrs
+val output : bodyTag boxAttrs
+val keygen : bodyTag boxAttrs
+val datalist : bodyTag boxAttrs
+
+(** Interactive Elements **)
+val details : bodyTag boxAttrs
+val dialog : bodyTag boxAttrs
+val menuitem : bodyTag boxAttrs
+
+(** Grouping Content **)
+val figure : bodyTag boxAttrs
+val figcaption : bodyTag boxAttrs
+
+(** Text Level Semantics **)
+val data : bodyTag boxAttrs
+val mark : bodyTag boxAttrs
+val rp : bodyTag boxAttrs
+val rt : bodyTag boxAttrs
+val ruby : bodyTag boxAttrs
+val summary : bodyTag boxAttrs
+val time : bodyTag boxAttrs
+val wbr : bodyTag boxAttrs
+val bdi : bodyTag boxAttrs
+
val a : bodyTag ([Link = transaction page, Href = url, Target = string, Rel = string] ++ boxAttrs)
val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int,
@@ -899,7 +943,7 @@ con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
-> [[Form] ~ ctx] =>
nm :: Name -> unit
-> tag attrs ([Form] ++ ctx) inner [] [nm = ty]
-val hidden : formTag string [] [Id = string, Value = string]
+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)
@@ -933,12 +977,12 @@ val fieldValue : postField -> string
val remainingFields : postField -> string
con radio = [Body, Radio]
-val radio : formTag (option string) radio [Id = id]
+val radio : formTag (option string) radio [Data = data_attr, Id = id]
val radioOption : unit -> tag ([Value = string, Checked = bool] ++ boxAttrs) radio [] [] []
con select = [Select]
val select : formTag string select ([Onchange = transaction unit] ++ boxAttrs)
-val option : unit -> tag [Value = string, Selected = bool] select [] [] []
+val option : unit -> tag [Data = data_attr, Value = string, Selected = bool] select [] [] []
val submit : ctx ::: {Unit} -> use ::: {Type}
-> [[Form] ~ ctx] =>
@@ -990,19 +1034,30 @@ val td : other ::: {Unit} -> [other ~ [Body, Tr]] => unit
-> tag ([Colspan = int, Rowspan = int] ++ tableAttrs)
([Tr] ++ other) ([Body] ++ other) [] []
+val thead : other ::: {Unit} -> [other ~ [Table]] => unit
+ -> tag tableAttrs
+ ([Table] ++ other) ([Table] ++ other) [] []
+val tbody : other ::: {Unit} -> [other ~ [Table]] => unit
+ -> tag tableAttrs
+ ([Table] ++ other) ([Table] ++ other) [] []
+val tfoot : other ::: {Unit} -> [other ~ [Table]] => unit
+ -> tag tableAttrs
+ ([Table] ++ other) ([Table] ++ other) [] []
+
(** Definition lists *)
val dl : other ::: {Unit} -> [other ~ [Body,Dl]]
=> unit
- -> tag [] ([Body] ++ other) ([Dl] ++ other) [] []
+ -> tag [Data = data_attr] ([Body] ++ other) ([Dl] ++ other) [] []
val dt : other ::: {Unit} -> [other ~ [Body,Dl]]
=> unit
- -> tag [] ([Dl] ++ other) ([Body] ++ other) [] []
+ -> tag [Data = data_attr] ([Dl] ++ other) ([Body] ++ other) [] []
val dd : other ::: {Unit} -> [other ~ [Body,Dl]]
=> unit
- -> tag [] ([Dl] ++ other) ([Body] ++ other) [] []
+ -> tag [Data = data_attr] ([Dl] ++ other) ([Body] ++ other) [] []
+
(** Aborting *)
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 30f1eaad..2ea86dc4 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -155,6 +155,10 @@ val mapX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type)
-> r ::: {K} -> folder r
-> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> xml ctx [] []
+(* Note that the next two functions return elements in the _reverse_ of the natural order!
+ * Such a choice interacts well with the time complexity of standard list operations.
+ * It's easy to regain the natural order by inverting a query's 'ORDER BY' condition. *)
+
val queryL : tables ::: {{Type}} -> exps ::: {Type}
-> [tables ~ exps] =>
sql_query [] [] tables exps
diff --git a/src/c/cgi.c b/src/c/cgi.c
index 539b83c2..d060532c 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -60,8 +60,10 @@ static void log_error(void *data, const char *fmt, ...) {
static void log_debug(void *data, const char *fmt, ...) {
}
+static uw_loggers ls = {NULL, log_error, log_debug};
+
int main(int argc, char *argv[]) {
- uw_context ctx = uw_request_new_context(0, &uw_application, NULL, log_error, log_debug);
+ uw_context ctx = uw_request_new_context(0, &uw_application, &ls);
uw_request_context rc = uw_new_request_context();
request_result rr;
char *method = getenv("REQUEST_METHOD"),
@@ -108,7 +110,7 @@ int main(int argc, char *argv[]) {
uw_set_on_success("");
uw_set_headers(ctx, get_header, NULL);
uw_set_env(ctx, get_env, NULL);
- uw_request_init(&uw_application, NULL, log_error, log_debug);
+ uw_request_init(&uw_application, &ls);
body[body_pos] = 0;
rr = uw_request(rc, ctx, method, path, query_string, body, body_pos,
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index 5c80d3ae..f3e66e3a 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -324,7 +324,8 @@ int fastcgi_send_normal(int sock, const void *buf, ssize_t len) {
static void *worker(void *data) {
FCGI_Input *in = fastcgi_input();
FCGI_Output *out = fastcgi_output();
- uw_context ctx = uw_request_new_context(*(int *)data, &uw_application, out, log_error, log_debug);
+ uw_loggers ls = {out, log_error, log_debug};
+ uw_context ctx = uw_request_new_context(*(int *)data, &uw_application, &ls);
uw_request_context rc = uw_new_request_context();
headers hs;
size_t body_size = 0;
@@ -514,7 +515,7 @@ static void sigint(int signum) {
exit(0);
}
-static loggers ls = {&uw_application, NULL, log_error, log_debug};
+static uw_loggers ls = {NULL, log_error, log_debug};
int main(int argc, char *argv[]) {
// The skeleton for this function comes from Beej's sockets tutorial.
@@ -563,7 +564,7 @@ int main(int argc, char *argv[]) {
}
uw_set_on_success("");
- uw_request_init(&uw_application, NULL, log_error, log_debug);
+ uw_request_init(&uw_application, &ls);
names = calloc(nthreads, sizeof(int));
@@ -572,7 +573,11 @@ int main(int argc, char *argv[]) {
{
pthread_t thread;
- if (pthread_create_big(&thread, NULL, client_pruner, &ls)) {
+ pruner_data *pd = (pruner_data *)malloc(sizeof(pruner_data));
+ pd->app = &uw_application;
+ pd->loggers = &ls;
+
+ if (pthread_create_big(&thread, NULL, client_pruner, pd)) {
fprintf(stderr, "Error creating pruner thread\n");
return 1;
}
diff --git a/src/c/http.c b/src/c/http.c
index 25d2a320..32dd1dd1 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -70,9 +70,11 @@ static void log_debug(void *data, const char *fmt, ...) {
}
}
+static uw_loggers ls = {NULL, log_error, log_debug};
+
static void *worker(void *data) {
int me = *(int *)data;
- uw_context ctx = uw_request_new_context(me, &uw_application, NULL, log_error, log_debug);
+ uw_context ctx = uw_request_new_context(me, &uw_application, &ls);
size_t buf_size = 1024;
char *buf = malloc(buf_size), *back = buf;
uw_request_context rc = uw_new_request_context();
@@ -307,8 +309,6 @@ static void sigint(int signum) {
exit(0);
}
-static loggers ls = {&uw_application, NULL, log_error, log_debug};
-
int main(int argc, char *argv[]) {
// The skeleton for this function comes from Beej's sockets tutorial.
int sockfd; // listen on sock_fd
@@ -374,7 +374,7 @@ int main(int argc, char *argv[]) {
}
}
- uw_request_init(&uw_application, NULL, log_error, log_debug);
+ uw_request_init(&uw_application, &ls);
names = calloc(nthreads, sizeof(int));
@@ -411,7 +411,11 @@ int main(int argc, char *argv[]) {
{
pthread_t thread;
- if (pthread_create_big(&thread, NULL, client_pruner, &ls)) {
+ pruner_data *pd = (pruner_data *)malloc(sizeof(pruner_data));
+ pd->app = &uw_application;
+ pd->loggers = &ls;
+
+ if (pthread_create_big(&thread, NULL, client_pruner, pd)) {
fprintf(stderr, "Error creating pruner thread\n");
return 1;
}
diff --git a/src/c/request.c b/src/c/request.c
index b925cc3c..813d967c 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -12,6 +12,7 @@
#include <pthread.h>
#include "urweb.h"
+#include "request.h"
#define MAX_RETRIES 5
@@ -32,8 +33,11 @@ static int try_rollback(uw_context ctx, int will_retry, void *logger_data, uw_lo
return r;
}
-uw_context uw_request_new_context(int id, uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) {
- uw_context ctx = uw_init(id, logger_data, log_debug);
+uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls) {
+ void *logger_data = ls->logger_data;
+ uw_logger log_debug = ls->log_debug;
+ uw_logger log_error = ls->log_error;
+ uw_context ctx = uw_init(id, ls);
int retries_left = MAX_RETRIES;
uw_set_app(ctx, app);
@@ -78,20 +82,15 @@ static void *ticker(void *data) {
}
typedef struct {
- uw_app *app;
- void *logger_data;
- uw_logger log_error, log_debug;
-} loggers;
-
-typedef struct {
int id;
- loggers *ls;
+ uw_loggers *ls;
uw_periodic pdic;
+ uw_app *app;
} periodic;
static void *periodic_loop(void *data) {
periodic *p = (periodic *)data;
- uw_context ctx = uw_request_new_context(p->id, p->ls->app, p->ls->logger_data, p->ls->log_error, p->ls->log_debug);
+ uw_context ctx = uw_request_new_context(p->id, p->app, p->ls);
if (!ctx)
exit(1);
@@ -145,14 +144,17 @@ int pthread_create_big(pthread_t *outThread, void *foo, void *threadFunc, void *
}
}
-void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_logger log_debug) {
+void uw_request_init(uw_app *app, uw_loggers* ls) {
uw_context ctx;
failure_kind fk;
uw_periodic *ps;
- loggers *ls = malloc(sizeof(loggers));
int id;
char *stackSize_s;
+ uw_logger log_debug = ls->log_debug;
+ uw_logger log_error = ls->log_error;
+ void* logger_data = ls->logger_data;
+
if ((stackSize_s = getenv("URWEB_STACK_SIZE")) != NULL && stackSize_s[0] != 0) {
stackSize = atoll(stackSize_s);
@@ -162,11 +164,6 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log
}
}
- ls->app = app;
- ls->logger_data = logger_data;
- ls->log_error = log_error;
- ls->log_debug = log_debug;
-
uw_global_init();
uw_app_init(app);
@@ -179,7 +176,7 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log
}
}
- ctx = uw_request_new_context(0, app, logger_data, log_error, log_debug);
+ ctx = uw_request_new_context(0, app, ls);
if (!ctx)
exit(1);
@@ -205,6 +202,7 @@ void uw_request_init(uw_app *app, void *logger_data, uw_logger log_error, uw_log
arg->id = id++;
arg->ls = ls;
arg->pdic = *ps;
+ arg->app = app;
if (pthread_create_big(&thread, NULL, periodic_loop, arg)) {
fprintf(stderr, "Error creating periodic thread\n");
@@ -240,7 +238,7 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
void (*on_success)(uw_context), void (*on_failure)(uw_context),
void *logger_data, uw_logger log_error, uw_logger log_debug,
int sock,
- int (*send)(int sockfd, const void *buf, size_t len),
+ int (*send)(int sockfd, const void *buf, ssize_t len),
int (*close)(int fd)) {
int retries_left = MAX_RETRIES;
failure_kind fk;
@@ -588,8 +586,8 @@ request_result uw_request(uw_request_context rc, uw_context ctx,
}
void *client_pruner(void *data) {
- loggers *ls = (loggers *)data;
- uw_context ctx = uw_request_new_context(0, ls->app, ls->logger_data, ls->log_error, ls->log_debug);
+ pruner_data *pd = (pruner_data *)data;
+ uw_context ctx = uw_request_new_context(0, pd->app, pd->loggers);
if (!ctx)
exit(1);
diff --git a/src/c/static.c b/src/c/static.c
index 80ea5387..8f35a2d4 100644
--- a/src/c/static.c
+++ b/src/c/static.c
@@ -7,13 +7,15 @@
extern uw_app uw_application;
-static void log_debug(void *data, const char *fmt, ...) {
+static void log_(void *data, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
vprintf(fmt, ap);
}
+static uw_loggers loggers = {NULL, log_, log_};
+
int main(int argc, char *argv[]) {
uw_context ctx;
failure_kind fk;
@@ -23,7 +25,7 @@ int main(int argc, char *argv[]) {
return 1;
}
- ctx = uw_init(0, NULL, log_debug);
+ ctx = uw_init(0, &loggers);
uw_set_app(ctx, &uw_application);
uw_initialize(ctx);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index d4c0b439..78afcd05 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -460,8 +460,7 @@ struct uw_context {
void *client_data;
- void *logger_data;
- uw_logger log_debug;
+ uw_loggers *loggers;
int isPost, hasPostBody;
uw_Basis_postBody postBody;
@@ -487,7 +486,7 @@ size_t uw_page_max = SIZE_MAX;
size_t uw_heap_max = SIZE_MAX;
size_t uw_script_max = SIZE_MAX;
-uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
+uw_context uw_init(int id, uw_loggers *lg) {
uw_context ctx = malloc(sizeof(struct uw_context));
ctx->app = NULL;
@@ -546,8 +545,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
ctx->client_data = uw_init_client_data();
- ctx->logger_data = logger_data;
- ctx->log_debug = log_debug;
+ ctx->loggers = lg;
ctx->isPost = ctx->hasPostBody = 0;
@@ -601,6 +599,11 @@ void *uw_get_db(uw_context ctx) {
return ctx->db;
}
+
+uw_loggers* uw_get_loggers(struct uw_context *ctx) {
+ return ctx->loggers;
+}
+
void uw_free(uw_context ctx) {
size_t i;
@@ -1258,17 +1261,34 @@ void uw_end_initializing(uw_context ctx) {
ctx->amInitializing = 0;
}
+static void align_heap(uw_context ctx) {
+ size_t posn = ctx->heap.front - ctx->heap.start;
+
+ if (posn % 4 != 0) {
+ size_t bump = 4 - posn % 4;
+ uw_check_heap(ctx, bump);
+ ctx->heap.front += bump;
+ }
+}
+
void *uw_malloc(uw_context ctx, size_t len) {
+ // On some architectures, it's important that all word-sized memory accesses
+ // be to word-aligned addresses, so we'll do a little bit of extra work here
+ // in anticipation of a possible word-aligned access to the address we'll
+ // return.
+
void *result;
if (ctx->amInitializing) {
- result = malloc(len);
+ int error = posix_memalign(&result, 4, len);
- if (result)
+ if (!error)
return result;
else
- uw_error(ctx, FATAL, "uw_malloc: malloc() returns 0");
+ uw_error(ctx, FATAL, "uw_malloc: posix_memalign() returns %d", error);
} else {
+ align_heap(ctx);
+
uw_check_heap(ctx, len);
result = ctx->heap.front;
@@ -1278,6 +1298,8 @@ void *uw_malloc(uw_context ctx, size_t len) {
}
void uw_begin_region(uw_context ctx) {
+ align_heap(ctx);
+
regions *r = (regions *) ctx->heap.front;
uw_check_heap(ctx, sizeof(regions));
@@ -1588,6 +1610,9 @@ uw_Basis_source uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
int len;
size_t s_len = strlen(s);
+ if(ctx->id < 0)
+ uw_error(ctx, FATAL, "Attempt to create client source using inappropriate context");
+
uw_check_script(ctx, 15 + 2 * INTS_MAX + s_len);
sprintf(ctx->script.front, "s%d_%llu=sc(exec(%n", ctx->id, ctx->source_count, &len);
ctx->script.front += len;
@@ -3316,32 +3341,58 @@ int uw_commit(uw_context ctx) {
}
}
- for (i = ctx->used_transactionals-1; i >= 0; --i)
- if (ctx->transactionals[i].rollback == NULL)
- if (ctx->transactionals[i].commit) {
- ctx->transactionals[i].commit(ctx->transactionals[i].data);
- if (uw_has_error(ctx)) {
- uw_rollback(ctx, 0);
- return 0;
- }
- }
-
if (ctx->transaction_started) {
int code = ctx->app->db_commit(ctx);
if (code) {
- if (code == -1)
+ if (ctx->client)
+ release_client(ctx->client);
+
+ if (code == -1) {
+ // This case is for a serialization failure, which is not really an "error."
+ // The transaction will restart, so we should rollback any transactionals
+ // that triggered above.
+
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].rollback != NULL)
+ ctx->transactionals[i].rollback(ctx->transactionals[i].data);
+
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].free)
+ ctx->transactionals[i].free(ctx->transactionals[i].data, 1);
+
return 1;
+ }
for (i = ctx->used_transactionals-1; i >= 0; --i)
- if (ctx->transactionals[i].free)
- ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
+ if (ctx->transactionals[i].free)
+ ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
uw_set_error_message(ctx, "Error running SQL COMMIT");
return 0;
}
}
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].rollback == NULL)
+ if (ctx->transactionals[i].commit) {
+ ctx->transactionals[i].commit(ctx->transactionals[i].data);
+ if (uw_has_error(ctx)) {
+ if (ctx->client)
+ release_client(ctx->client);
+
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].rollback != NULL)
+ ctx->transactionals[i].rollback(ctx->transactionals[i].data);
+
+ for (i = ctx->used_transactionals-1; i >= 0; --i)
+ if (ctx->transactionals[i].free)
+ ctx->transactionals[i].free(ctx->transactionals[i].data, 0);
+
+ return 0;
+ }
+ }
+
for (i = 0; i < ctx->used_deltas; ++i) {
delta *d = &ctx->deltas[i];
client *c = find_client(d->client);
@@ -3455,11 +3506,12 @@ int uw_commit(uw_context ctx) {
size_t uw_transactionals_max = SIZE_MAX;
-void uw_register_transactional(uw_context ctx, void *data, uw_callback commit, uw_callback rollback,
+int uw_register_transactional(uw_context ctx, void *data, uw_callback commit, uw_callback rollback,
uw_callback_with_retry free) {
if (ctx->used_transactionals >= ctx->n_transactionals) {
if (ctx->used_transactionals+1 > uw_transactionals_max)
- uw_error(ctx, FATAL, "Exceeded limit on number of transactionals");
+ // Exceeded limit on number of transactionals.
+ return -1;
ctx->transactionals = realloc(ctx->transactionals, sizeof(transactional) * (ctx->used_transactionals+1));
++ctx->n_transactionals;
}
@@ -3468,6 +3520,8 @@ void uw_register_transactional(uw_context ctx, void *data, uw_callback commit, u
ctx->transactionals[ctx->used_transactionals].commit = commit;
ctx->transactionals[ctx->used_transactionals].rollback = rollback;
ctx->transactionals[ctx->used_transactionals++].free = free;
+
+ return 0;
}
@@ -3965,7 +4019,8 @@ uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) {
uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) {
struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day,
- .tm_hour = hour, .tm_min = minute, .tm_sec = second };
+ .tm_hour = hour, .tm_min = minute, .tm_sec = second,
+ .tm_isdst = -1 };
uw_Basis_time r = { timelocal(&tm) };
return r;
}
@@ -4136,8 +4191,8 @@ uw_Basis_int uw_Basis_naughtyDebug(uw_context ctx, uw_Basis_string s) {
}
uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) {
- if (ctx->log_debug)
- ctx->log_debug(ctx->logger_data, "%s\n", s);
+ if (ctx->loggers->log_debug)
+ ctx->loggers->log_debug(ctx->loggers->logger_data, "%s\n", s);
else
fprintf(stderr, "%s\n", s);
return uw_unit_v;
@@ -4379,3 +4434,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) {
return f;
}
+
+uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) {
+ char *p = s;
+
+ for (; *p; ++p)
+ if (!isalnum(*p) && *p != '-' && *p != '_')
+ uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s);
+
+ return s;
+}
diff --git a/src/compiler.sml b/src/compiler.sml
index 37272758..fd143485 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -874,6 +874,7 @@ fun parseUrp' accLibs fname =
| "timeFormat" => Settings.setTimeFormat arg
| "noMangleSql" => Settings.setMangleSql false
| "html5" => Settings.setIsHtml5 true
+ | "lessSafeFfi" => Settings.setLessSafeFfi true
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
diff --git a/src/corify.sml b/src/corify.sml
index 085b2eb8..b08ef7eb 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -643,6 +643,12 @@ fun corifyExp st (e, loc) =
| L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc)
+fun isTransactional (c, _) =
+ case c of
+ L'.TFun (_, c) => isTransactional c
+ | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
+ | _ => false
+
fun corifyDecl mods (all as (d, loc : EM.span), st) =
case d of
L.DCon (x, n, k, c) =>
@@ -970,12 +976,6 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
in
transactify c
end
-
- fun isTransactional (c, _) =
- case c of
- L'.TFun (_, c) => isTransactional c
- | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
- | _ => false
in
if isTransactional c then
let
@@ -1164,6 +1164,66 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
([], st))
end
+ | L.DFfi (x, n, modes, t) =>
+ let
+ val m = case St.name st of
+ [m] => m
+ | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level";
+ "")
+
+ val name = (m, x)
+
+ val (st, n) = St.bindVal st x n
+ val s = doRestify Settings.Url (mods, x)
+
+ val t' = corifyCon st t
+
+ fun numArgs (t : L'.con) =
+ case #1 t of
+ L'.TFun (_, ran) => 1 + numArgs ran
+ | _ => 0
+
+ fun makeArgs (i, t : L'.con, acc) =
+ case #1 t of
+ L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc)
+ | _ => rev acc
+
+ fun wrapAbs (i, t : L'.con, tTrans, e) =
+ case (#1 t, #1 tTrans) of
+ (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc)
+ | _ => e
+
+ fun getRan (t : L'.con) =
+ case #1 t of
+ L'.TFun (_, ran) => getRan ran
+ | _ => t
+
+ fun addLastBit (t : L'.con) =
+ case #1 t of
+ L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t)
+ | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc)
+
+ val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc)
+ val (e, tTrans) = if isTransactional t' then
+ ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t')
+ else
+ (e, t')
+ val e = wrapAbs (0, t', tTrans, e)
+ in
+ app (fn Source.Effectful => Settings.addEffectful name
+ | Source.BenignEffectful => Settings.addBenignEffectful name
+ | Source.ClientOnly => Settings.addClientOnly name
+ | Source.ServerOnly => Settings.addServerOnly name
+ | Source.JsFunc s => Settings.addJsFunc (name, s)) modes;
+
+ if isTransactional t' andalso not (Settings.isBenignEffectful name) then
+ Settings.addEffectful name
+ else
+ ();
+
+ ([(L'.DVal (x, n, t', e, s), loc)], st)
+ end
+
and corifyStr mods ((str, loc), st) =
case str of
L.StrConst ds =>
@@ -1237,7 +1297,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DStyle (_, _, n') => Int.max (n, n')
| L.DTask _ => n
| L.DPolicy _ => n
- | L.DOnError _ => n)
+ | L.DOnError _ => n
+ | L.DFfi (_, n', _, _) => Int.max (n, n'))
0 ds
and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 2dab5c34..249531f1 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2011, 2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -181,6 +181,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
+ | DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 465fb7e4..9fbe7bd7 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1681,5 +1681,6 @@ fun declBinds env (d, loc) =
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
+ | DFfi (x, n, _, t) => pushENamedAs env x n t
end
diff --git a/src/elab_err.sig b/src/elab_err.sig
index b5e3d64d..acf137df 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -81,6 +81,7 @@ signature ELAB_ERR = sig
| Unresolvable of ErrorMsg.span * Elab.con
| OutOfContext of ErrorMsg.span * (Elab.exp * Elab.con) option
| IllegalRec of string * Elab.exp
+ | IllegalFlex of Source.exp
val expError : ElabEnv.env -> exp_error -> unit
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 4754d4ce..33daa118 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -180,6 +180,7 @@ datatype exp_error =
| Unresolvable of ErrorMsg.span * con
| OutOfContext of ErrorMsg.span * (exp * con) option
| IllegalRec of string * exp
+ | IllegalFlex of Source.exp
val simplExp = U.Exp.mapB {kind = fn _ => fn k => k,
con = fn env => fn c => #1 (ElabOps.reduceCon env (c, ErrorMsg.dummySpan)),
@@ -251,6 +252,9 @@ fun expError env err =
(ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)";
eprefaces' [("Variable", PD.string x),
("Expression", p_exp env e)])
+ | IllegalFlex e =>
+ (ErrorMsg.errorAt (#2 e) "Flex record syntax (\"...\") only allowed in patterns";
+ eprefaces' [("Expression", SourcePrint.p_exp e)])
datatype decl_error =
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 7ce94c97..957d4646 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -852,6 +852,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 60245585..fef55852 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -927,7 +927,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
| DTask _ => ctx
| DPolicy _ => ctx
- | DOnError _ => ctx,
+ | DOnError _ => ctx
+ | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)),
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -1056,6 +1057,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
fn e1' =>
(DPolicy e1', loc))
| DOnError _ => S.return2 dAll
+ | DFfi (x, n, modes, t) =>
+ S.map2 (mfc ctx t,
+ fn t' =>
+ (DFfi (x, n, modes, t'), loc))
and mfvi ctx (x, n, c, e) =
S.bind2 (mfc ctx c,
@@ -1234,6 +1239,7 @@ and maxNameDecl (d, _) =
| DTask _ => 0
| DPolicy _ => 0
| DOnError _ => 0
+ | DFfi (_, n, _, _) => n
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 5dd86f18..d492883f 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2183,8 +2183,13 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
(e', (#1 (chaseUnifs t'), loc), enD gs2 @ gs1)
end
- | L.ERecord xes =>
+ | L.ERecord (xes, flex) =>
let
+ val () = if flex then
+ expError env (IllegalFlex eAll)
+ else
+ ()
+
val (xes', gs) = ListUtil.foldlMap (fn ((x, e), gs) =>
let
val (x', xk, gs1) = elabCon (env, denv) x
@@ -2994,6 +2999,7 @@ and sgiOfDecl (d, loc) =
| L'.DTask _ => []
| L'.DPolicy _ => []
| L'.DOnError _ => []
+ | L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)]
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -4293,6 +4299,20 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
end)
+ | L.DFfi (x, modes, t) =>
+ let
+ val () = if Settings.getLessSafeFfi () then
+ ()
+ else
+ ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory."
+
+ val (t', _, gs1) = elabCon (env, denv) t
+ val t' = normClassConstraint env t'
+ val (env', n) = E.pushENamed env x t'
+ in
+ ([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs))
+ end
+
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
(*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll),
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index f183a9ab..edbff1b0 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -139,7 +139,7 @@ See doc for the variable `urweb-mode-info'."
"of" "open" "let" "in"
"rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
"struct" "structure" "table" "view" "then" "type" "val" "where"
- "with"
+ "with" "ffi"
"Name" "Type" "Unit")
"A regexp that matches any non-SQL keywords of Ur/Web.")
diff --git a/src/expl.sml b/src/expl.sml
index 0d4e63cc..3d784e3f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -150,6 +150,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of int * string list * string
+ | DFfi of string * int * Source.ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index f5a5eb0a..5712a72d 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -346,6 +346,7 @@ fun declBinds env (d, loc) =
| DTask _ => env
| DPolicy _ => env
| DOnError _ => env
+ | DFfi (x, n, _, t) => pushENamed env x n t
fun sgiBinds env (sgi, loc) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index a830dccb..22d246e2 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -731,6 +731,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_exp env e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str env (str, _) =
case str of
diff --git a/src/expl_rename.sml b/src/expl_rename.sml
index 7e7a155a..bb763a60 100644
--- a/src/expl_rename.sml
+++ b/src/expl_rename.sml
@@ -219,6 +219,7 @@ fun renameDecl st (all as (d, loc)) =
(case St.lookup (st, n) of
NONE => all
| SOME n' => (DOnError (n', xs, x), loc))
+ | DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc)
and renameStr st (all as (str, loc)) =
case str of
@@ -413,6 +414,15 @@ fun dupDecl (all as (d, loc), st) =
(case St.lookup (st, n) of
NONE => ([all], st)
| SOME n' => ([(DOnError (n', xs, x), loc)], st))
+ | DFfi (x, n, modes, t) =>
+ let
+ val (st, n') = St.bind (st, n)
+ val t' = renameCon st t
+ in
+ ([(DFfi (x, n, modes, t'), loc),
+ (DVal (x, n', t', (ENamed n, loc)), loc)],
+ st)
+ end
fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} =
case str of
diff --git a/src/explify.sml b/src/explify.sml
index 4c60bd20..fd0f3277 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -198,6 +198,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
| L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
| L.DOnError v => SOME (L'.DOnError v, loc)
+ | L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/jscomp.sig b/src/jscomp.sig
index 929c507d..5b8723b4 100644
--- a/src/jscomp.sig
+++ b/src/jscomp.sig
@@ -29,4 +29,8 @@ signature JSCOMP = sig
val process : Mono.file -> Mono.file
+ val explainEmbed : bool ref
+ (* Output verbose error messages about inability to embed server-side
+ * values in client-side code? *)
+
end
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 4a2c0365..bcabed0b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -41,6 +41,8 @@ structure TM = BinaryMapFn(struct
val compare = U.Typ.compare
end)
+val explainEmbed = ref false
+
type state = {
decls : (string * int * (string * int * typ option) list) list,
script : string list,
@@ -267,7 +269,12 @@ fun process (file : file) =
((EApp ((ENamed n', loc), e), loc), st)
end)
- | _ => ((*Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];*)
+ | _ => (if !explainEmbed then
+ Print.prefaces "Can't embed" [("loc", Print.PD.string (ErrorMsg.spanToString loc)),
+ ("e", MonoPrint.p_exp MonoEnv.empty e),
+ ("t", MonoPrint.p_typ MonoEnv.empty t)]
+ else
+ ();
raise CantEmbed t)
fun unurlifyExp loc (t : typ, st) =
@@ -400,6 +407,9 @@ fun process (file : file) =
fun jsE inner (e as (_, loc), st) =
let
+ (*val () = Print.prefaces "jsExp" [("e", MonoPrint.p_exp MonoEnv.empty e),
+ ("loc", Print.PD.string (ErrorMsg.spanToString loc))]*)
+
val str = str loc
fun patCon pc =
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 71fefc48..bfc18e59 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -174,6 +174,9 @@ fun oneRun args =
else
Settings.addLimit (class, n);
doArgs rest)
+ | "-explainEmbed" :: rest =>
+ (JsComp.explainEmbed := true;
+ doArgs rest)
| arg :: rest =>
(if size arg > 0 andalso String.sub (arg, 0) = #"-" then
raise Fail ("Unknown flag " ^ arg)
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 228c53e6..ae306e68 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -118,6 +118,9 @@ fun unAs s =
end
fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s
+val checkData = CharVector.all (fn ch => Char.isAlphaNum ch
+ orelse ch = #"_"
+ orelse ch = #"-")
val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch
orelse ch = #"+"
orelse ch = #"-"
@@ -442,6 +445,13 @@ fun exp e =
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
+ | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) =>
+ (if checkData s then
+ ()
+ else
+ ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s);
+ se)
+
| EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) =>
(if checkUrl s then
()
diff --git a/src/monoize.sml b/src/monoize.sml
index 000ba7b6..f7344fed 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2013, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -235,6 +235,7 @@ fun monoType env =
| L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
@@ -2131,7 +2132,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcatComma
(map (fn (x', _) =>
sc ("T_" ^ x
- ^ ""
+ ^ "."
^ Settings.mangleSql x'))
xts)) grouped)
],
@@ -3117,6 +3118,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) =>
+ let
+ val (s1, fm) = monoExp (env, st, fm) s1
+ val (s2, fm) = monoExp (env, st, fm) s2
+ in
+ ((L'.EStrcat ((L'.EPrim (Prim.String "data-"), loc),
+ (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc),
+ (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
+ (L'.EPrim (Prim.String "\""), loc)), loc)),
+ loc)), loc)), loc),
+ fm)
+ end
+
+ | L.EFfiApp ("Basis", "data_attrs", [(s1, _), (s2, _)]) =>
+ let
+ val (s1, fm) = monoExp (env, st, fm) s1
+ val (s2, fm) = monoExp (env, st, fm) s2
+ in
+ ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc),
+ fm)
+ end
+
| L.EFfiApp ("Basis", "css_url", [(s, _)]) =>
let
val (s, fm) = monoExp (env, st, fm) s
@@ -3206,7 +3230,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.EFfi ("Basis", "tag"),
- _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
+ _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _),
class), _),
dynClass), _),
style), _),
@@ -3317,6 +3341,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
| (("Source", _, _), acc) => acc
+ | (("Data", e, _), (s, fm)) =>
+ ((L'.EStrcat (s,
+ (L'.EStrcat (
+ (L'.EPrim (Prim.String " "), loc),
+ e), loc)), loc),
+ fm)
| ((x, e, t), (s, fm)) =>
case t of
(L'.TFfi ("Basis", "bool"), _) =>
@@ -3551,6 +3581,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EPrim (Prim.String ")"), loc)), loc)), loc)
end
+ fun inTag tag' = case ctxOuter of
+ (L.CRecord (_, ctx), _) =>
+ List.exists (fn ((L.CName tag'', _), _) => tag'' = tag'
+ | _ => false) ctx
+ | _ => false
+
+ fun pnode () = if inTag "Tr" then
+ "tr"
+ else if inTag "Table" then
+ "table"
+ else
+ "span"
+
val baseAll as (base, fm) =
case tag of
"body" => let
@@ -3573,24 +3616,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "dyn" =>
let
- fun inTag tag = case targs of
- (L.CRecord (_, ctx), _) :: _ =>
- List.exists (fn ((L.CName tag', _), _) => tag' = tag
- | _ => false) ctx
- | _ => false
-
- val tag = if inTag "Tr" then
- "tr"
- else if inTag "Table" then
- "table"
- else
- "span"
in
case attrs of
[("Signal", e, _)] =>
((L'.EStrcat
((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\""
- ^ tag ^ "\", execD(")), loc),
+ ^ pnode () ^ "\", execD(")), loc),
(L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
(L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
fm)
@@ -3804,7 +3835,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
L'.ENone _ =>
(case #1 dynStyle of
L'.ENone _ => baseAll
- | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+ | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"",
+ str (pnode ()),
+ str "\",execD(",
(L'.EJavaScript (L'.Script, base), loc),
str "),null,execD(",
(L'.EJavaScript (L'.Script, ds), loc),
@@ -3822,7 +3855,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown";
str "null")
in
- (strcat [str "<script type=\"text/javascript\">dynClass(execD(",
+ (strcat [str "<script type=\"text/javascript\">dynClass(\"",
+ str (pnode ()),
+ str "\",execD(",
(L'.EJavaScript (L'.Script, base), loc),
str "),execD(",
(L'.EJavaScript (L'.Script, dc), loc),
diff --git a/src/settings.sig b/src/settings.sig
index 20dd00c2..29c4c506 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -78,18 +78,22 @@ signature SETTINGS = sig
(* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *)
val setBenignEffectful : ffi list -> unit
+ val addBenignEffectful : ffi -> unit
val isBenignEffectful : ffi -> bool
(* Which FFI functions may only be run in clients? *)
val setClientOnly : ffi list -> unit
+ val addClientOnly : ffi -> unit
val isClientOnly : ffi -> bool
(* Which FFI functions may only be run on servers? *)
val setServerOnly : ffi list -> unit
+ val addServerOnly : ffi -> unit
val isServerOnly : ffi -> bool
(* Which FFI functions may be run in JavaScript? (JavaScript function names included) *)
val setJsFuncs : (ffi * string) list -> unit
+ val addJsFunc : ffi * string -> unit
val jsFunc : ffi -> string option
val allJsFuncs : unit -> (ffi * string) list
@@ -271,4 +275,7 @@ signature SETTINGS = sig
val setIsHtml5 : bool -> unit
val getIsHtml5 : unit -> bool
+
+ val setLessSafeFfi : bool -> unit
+ val getLessSafeFfi : unit -> bool
end
diff --git a/src/settings.sml b/src/settings.sml
index 6282577d..f00a4853 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -194,6 +194,7 @@ val benignBase = basis ["get_cookie",
val benign = ref benignBase
fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
+fun addBenignEffectful x = benign := S.add (!benign, x)
fun isBenignEffectful x = S.member (!benign, x)
val clientBase = basis ["get_client_source",
@@ -225,6 +226,7 @@ val clientBase = basis ["get_client_source",
"giveFocus"]
val client = ref clientBase
fun setClientOnly ls = client := S.addList (clientBase, ls)
+fun addClientOnly x = client := S.add (!client, x)
fun isClientOnly x = S.member (!client, x)
val serverBase = basis ["requestHeader",
@@ -240,6 +242,7 @@ val serverBase = basis ["requestHeader",
"firstFormField"]
val server = ref serverBase
fun setServerOnly ls = server := S.addList (serverBase, ls)
+fun addServerOnly x = server := S.add (!server, x)
fun isServerOnly x = S.member (!server, x)
val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
@@ -309,6 +312,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("checkUrl", "checkUrl"),
("bless", "bless"),
+ ("blessData", "blessData"),
("eq_time", "eq"),
("lt_time", "lt"),
@@ -363,6 +367,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
val jsFuncs = ref jsFuncsBase
fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
fun jsFunc x = M.find (!jsFuncs, x)
+fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
fun allJsFuncs () = M.listItemsi (!jsFuncs)
datatype pattern_kind = Exact | Prefix
@@ -734,4 +739,8 @@ val html5 = ref false
fun setIsHtml5 b = html5 := b
fun getIsHtml5 () = !html5
+val less = ref false
+fun setLessSafeFfi b = less := b
+fun getLessSafeFfi () = !less
+
end
diff --git a/src/source.sml b/src/source.sml
index 639ea716..2a741dd9 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -125,7 +125,7 @@ and exp' =
| EKAbs of string * exp
- | ERecord of (con * exp) list
+ | ERecord of (con * exp) list * bool
| EField of exp * con
| EConcat of exp * exp
| ECut of exp * con
@@ -147,6 +147,13 @@ and pat = pat' located
and exp = exp' located
and edecl = edecl' located
+datatype ffi_mode =
+ Effectful
+ | BenignEffectful
+ | ClientOnly
+ | ServerOnly
+ | JsFunc of string
+
datatype decl' =
DCon of string * kind option * con
| DDatatype of (string * string list * (string * con option) list) list
@@ -169,6 +176,7 @@ datatype decl' =
| DTask of exp * exp
| DPolicy of exp
| DOnError of string * string list * string
+ | DFfi of string * ffi_mode list * con
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index ce095542..db56a0db 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -277,14 +277,20 @@ fun p_exp' par (e, _) =
space,
string "!"])
- | ERecord xes => box [string "{",
- p_list (fn (x, e) =>
- box [p_name x,
- space,
- string "=",
- space,
- p_exp e]) xes,
- string "}"]
+ | ERecord (xes, flex) => box [string "{",
+ p_list (fn (x, e) =>
+ box [p_name x,
+ space,
+ string "=",
+ space,
+ p_exp e]) xes,
+ if flex then
+ box [string ",",
+ space,
+ string "..."]
+ else
+ box [],
+ string "}"]
| EField (e, c) => box [p_exp' true e,
string ".",
p_con' true c]
@@ -668,6 +674,7 @@ fun p_decl ((d, _) : decl) =
space,
p_exp e1]
| DOnError _ => string "ONERROR"
+ | DFfi _ => string "FFI"
and p_str (str, _) =
case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index 17bfd39f..fceb5026 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -452,6 +452,7 @@ fun unnest file =
| DTask _ => explore ()
| DPolicy _ => explore ()
| DOnError _ => default ()
+ | DFfi _ => default ()
end
and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 7063af38..157ecfac 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -225,7 +225,7 @@ fun tagIn bt =
datatype prop_kind = Delete | Update
-datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp
fun patType loc (p : pat) =
case #1 p of
@@ -322,6 +322,39 @@ fun applyWindow loc e window =
(EApp (e', ob), loc)
end
+fun patternOut (e : exp) =
+ case #1 e of
+ EWild => (PWild, #2 e)
+ | EVar ([], x, Infer) =>
+ if Char.isUpper (String.sub (x, 0)) then
+ (PCon ([], x, NONE), #2 e)
+ else
+ (PVar x, #2 e)
+ | EVar (xs, x, Infer) =>
+ if Char.isUpper (String.sub (x, 0)) then
+ (PCon (xs, x, NONE), #2 e)
+ else
+ (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern";
+ (PWild, #2 e))
+ | EPrim p => (PPrim p, #2 e)
+ | EApp ((EVar (xs, x, Infer), _), e') =>
+ (PCon (xs, x, SOME (patternOut e')), #2 e)
+ | ERecord (xes, flex) =>
+ (PRecord (map (fn (x, e') =>
+ let
+ val x =
+ case #1 x of
+ CName x => x
+ | _ => (ErrorMsg.errorAt (#2 e) "Field name not constant in pattern";
+ "")
+ in
+ (x, patternOut e')
+ end) xes, flex), #2 e)
+ | EAnnot (e', t) =>
+ (PAnnot (patternOut e', t), #2 e)
+ | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern.";
+ (PWild, #2 e))
+
%%
%header (functor UrwebLrValsFn(structure Token : TOKEN))
@@ -332,7 +365,7 @@ fun applyWindow loc e window =
| LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
| EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
| PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
- | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
+ | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI
| DATATYPE | OF
| TYPE | NAME
| ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
@@ -428,13 +461,13 @@ fun applyWindow loc e window =
| eapps of exp
| eterm of exp
| etuple of exp list
- | rexp of (con * exp) list
+ | rexp of (con * exp) list * bool
| xml of exp
| xmlOne of exp
| xmlOpt of exp
| tag of (string * exp) * exp option * exp option * exp
| tagHead of string * exp
- | bind of string * con option * exp
+ | bind of pat * con option * exp
| edecl of edecl
| edecls of edecl list
@@ -453,7 +486,7 @@ fun applyWindow loc e window =
| rpat of (string * pat) list * bool
| ptuple of pat list
- | attrs of exp option * exp option * exp option * exp option * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
| attr of attr
| attrv of exp
@@ -499,6 +532,9 @@ fun applyWindow loc e window =
| enterDml of unit
| leaveDml of unit
+ | ffi_mode of ffi_mode
+ | ffi_modes of ffi_mode list
+
%verbose (* print summary of errors *)
%pos int (* positions *)
@@ -612,6 +648,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
| STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
| TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
| POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))])
+ | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))])
dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
@@ -730,10 +767,10 @@ cst : UNIQUE tnames (let
val e = (EApp (e, mat), loc)
val e = (EApp (e, texp), loc)
in
- (EApp (e, (ERecord [((CName "OnDelete", loc),
- findMode Delete),
- ((CName "OnUpdate", loc),
- findMode Update)], loc)), loc)
+ (EApp (e, (ERecord ([((CName "OnDelete", loc),
+ findMode Delete),
+ ((CName "OnUpdate", loc),
+ findMode Update)], false), loc)), loc)
end)
| LBRACE eexp RBRACE (eexp)
@@ -779,7 +816,7 @@ pk : LBRACE LBRACE eexp RBRACE RBRACE (eexp)
val witness = map (fn (c, _) =>
(c, (EWild, loc)))
(#1 tnames :: #2 tnames)
- val witness = (ERecord witness, loc)
+ val witness = (ERecord (witness, false), loc)
in
(EApp (e, witness), loc)
end)
@@ -1136,11 +1173,17 @@ eexp : eapps (case #1 eapps of
end)
| bind SEMI eexp (let
val loc = s (bindleft, eexpright)
- val (v, to, e1) = bind
+ val (p, to, e1) = bind
val e = (EVar (["Basis"], "bind", Infer), loc)
val e = (EApp (e, e1), loc)
+
+ val f = case #1 p of
+ PVar v => (EAbs (v, to, eexp), loc)
+ | _ => (EAbs ("$x", to,
+ (ECase ((EVar ([], "$x", Infer), loc),
+ [(p, eexp)]), loc)), loc)
in
- (EApp (e, (EAbs (v, to, eexp), loc)), loc)
+ (EApp (e, f), loc)
end)
| eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
| eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
@@ -1181,17 +1224,17 @@ eexp : eapps (case #1 eapps of
val loc = s (eappsleft, eexpright)
in
(EApp ((EVar (["Basis"], "Cons", Infer), loc),
- (ERecord [((CName "1", loc),
- eapps),
- ((CName "2", loc),
- eexp)], loc)), loc)
+ (ERecord ([((CName "1", loc),
+ eapps),
+ ((CName "2", loc),
+ eexp)], false), loc)), loc)
end)
-bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps)
+bind : eapps LARROW eapps (patternOut eapps1, NONE, eapps2)
| eapps (let
val loc = s (eappsleft, eappsright)
in
- ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
+ ((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps)
end)
eargs : earg (earg)
@@ -1289,7 +1332,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
in
(ERecord (ListUtil.mapi (fn (i, e) =>
((CName (Int.toString (i + 1)), loc),
- e)) etuple), loc)
+ e)) etuple, false), loc)
end)
| path (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
@@ -1299,7 +1342,8 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
| AT cpath (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
| AT AT cpath (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
| LBRACE rexp RBRACE (ERecord rexp, s (LBRACEleft, RBRACEright))
- | UNIT (ERecord [], s (UNITleft, UNITright))
+ | LBRACE RBRACE (ERecord ([], false), s (LBRACEleft, RBRACEright))
+ | UNIT (ERecord ([], false), s (UNITleft, UNITright))
| INT (EPrim (Prim.Int INT), s (INTleft, INTright))
| FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
@@ -1386,7 +1430,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
^ " vs. " ^ Int.toString (length sqlexps) ^ ")")
else
();
- (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
+ (EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc)
end)
| LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
(let
@@ -1394,7 +1438,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright))
val e = (EVar (["Basis"], "update", Infer), loc)
val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
- val e = (EApp (e, (ERecord fsets, loc)), loc)
+ val e = (EApp (e, (ERecord (fsets, false), loc)), loc)
val e = (EApp (e, texp), loc)
in
(EApp (e, sqlexp), loc)
@@ -1486,9 +1530,9 @@ rpat : CSYMBOL EQ pat ([(CSYMBOL, pat)], false)
ptuple : pat COMMA pat ([pat1, pat2])
| pat COMMA ptuple (pat :: ptuple)
-rexp : ([])
- | ident EQ eexp ([(ident, eexp)])
- | ident EQ eexp COMMA rexp ((ident, eexp) :: rexp)
+rexp : DOTDOTDOT ([], true)
+ | ident EQ eexp ([(ident, eexp)], false)
+ | ident EQ eexp COMMA rexp ((ident, eexp) :: #1 rexp, #2 rexp)
xml : xmlOne xml (let
val pos = s (xmlOneleft, xmlright)
@@ -1602,9 +1646,33 @@ tag : tagHead attrs (let
| SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos),
e), pos)
val e = (EApp (e, eo), pos)
- val e = (EApp (e, (ERecord (#5 attrs), pos)), pos)
+
+ val atts = case #5 attrs of
+ [] => #6 attrs
+ | data :: datas =>
+ let
+ fun doOne (name, value) =
+ let
+ val e = (EVar (["Basis"], "data_attr", Infer), pos)
+ val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
+ in
+ (EApp (e, value), pos)
+ end
+
+ val datas' = foldl (fn (nv, acc) =>
+ let
+ val e = (EVar (["Basis"], "data_attrs", Infer), pos)
+ val e = (EApp (e, acc), pos)
+ in
+ (EApp (e, doOne nv), pos)
+ end) (doOne data) datas
+ in
+ ((CName "Data", pos), datas') :: #6 attrs
+ end
+
+ val e = (EApp (e, (ERecord (atts, false), pos)), pos)
val e = (EApp (e, (EApp (#2 tagHead,
- (ERecord [], pos)), pos)), pos)
+ (ERecord ([], false), pos)), pos)), pos)
in
(tagHead, #1 attrs, #2 attrs, e)
end)
@@ -1618,7 +1686,7 @@ tagHead: BEGIN_TAG (let
end)
| tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs : (NONE, NONE, NONE, NONE, [])
+attrs : (NONE, NONE, NONE, NONE, [], [])
| attr attrs (let
val loc = s (attrleft, attrsright)
in
@@ -1627,24 +1695,26 @@ attrs : (NONE, NONE, NONE, NONE, [])
(case #1 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
- (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
+ (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
| DynClass e =>
(case #2 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
- (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs))
+ (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 attrs))
| Style e =>
(case #3 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
- (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs))
+ (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 attrs))
| DynStyle e =>
(case #4 attrs of
NONE => ()
| SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
- (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs))
+ (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+ | Data xe =>
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
| Normal xe =>
- (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
end)
attr : SYMBOL EQ attrv (case SYMBOL of
@@ -1653,23 +1723,26 @@ attr : SYMBOL EQ attrv (case SYMBOL of
| "style" => Style attrv
| "dynStyle" => DynStyle attrv
| _ =>
- let
- val sym = makeAttr SYMBOL
- in
- Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
- if (sym = "Href" orelse sym = "Src")
- andalso (case #1 attrv of
- EPrim _ => true
- | _ => false) then
- let
- val loc = s (attrvleft, attrvright)
- in
- (EApp ((EVar (["Basis"], "bless", Infer), loc),
- attrv), loc)
- end
- else
- attrv)
- end)
+ if String.isPrefix "data-" SYMBOL then
+ Data (String.extract (SYMBOL, 5, NONE), attrv)
+ else
+ let
+ val sym = makeAttr SYMBOL
+ in
+ Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
+ if (sym = "Href" orelse sym = "Src")
+ andalso (case #1 attrv of
+ EPrim _ => true
+ | _ => false) then
+ let
+ val loc = s (attrvleft, attrvright)
+ in
+ (EApp ((EVar (["Basis"], "bless", Infer), loc),
+ attrv), loc)
+ end
+ else
+ attrv)
+ end)
attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
| FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
@@ -1679,14 +1752,14 @@ attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTri
query : query1 obopt lopt ofopt (let
val loc = s (query1left, query1right)
- val re = (ERecord [((CName "Rows", loc),
- query1),
- ((CName "OrderBy", loc),
- obopt),
- ((CName "Limit", loc),
- lopt),
- ((CName "Offset", loc),
- ofopt)], loc)
+ val re = (ERecord ([((CName "Rows", loc),
+ query1),
+ ((CName "OrderBy", loc),
+ obopt),
+ ((CName "Limit", loc),
+ lopt),
+ ((CName "Offset", loc),
+ ofopt)], false), loc)
in
(EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
end)
@@ -1767,21 +1840,21 @@ query1 : SELECT dopt select FROM tables wopt gopt hopt
val e = (EVar (["Basis"], "sql_query1", Infer), loc)
val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
loc)), loc)
- val re = (ERecord [((CName "Distinct", loc),
- dopt),
- ((CName "From", loc),
- #2 tables),
- ((CName "Where", loc),
- wopt),
- ((CName "GroupBy", loc),
- grp),
- ((CName "Having", loc),
- hopt),
- ((CName "SelectFields", loc),
- (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
- sel), loc)),
- ((CName "SelectExps", loc),
- (ERecord exps, loc))], loc)
+ val re = (ERecord ([((CName "Distinct", loc),
+ dopt),
+ ((CName "From", loc),
+ #2 tables),
+ ((CName "Where", loc),
+ wopt),
+ ((CName "GroupBy", loc),
+ grp),
+ ((CName "Having", loc),
+ hopt),
+ ((CName "SelectFields", loc),
+ (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
+ sel), loc)),
+ ((CName "SelectExps", loc),
+ (ERecord (exps, false), loc))], false), loc)
val e = (EApp (e, re), loc)
in
@@ -1907,6 +1980,7 @@ fitem : table' ([#1 table'], #2 table')
in
([tname], (EApp (e, query), loc))
end)
+ | LPAREN fitem RPAREN (fitem)
tname : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
| LBRACE cexp RBRACE (cexp)
@@ -2197,3 +2271,16 @@ sqlagg : AVG ("avg")
| SUM ("sum")
| MIN ("min")
| MAX ("max")
+
+ffi_mode : SYMBOL (case SYMBOL of
+ "effectful" => Effectful
+ | "benignEffectful" => BenignEffectful
+ | "clientOnly" => ClientOnly
+ | "serverOnly" => ServerOnly
+ | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+ | SYMBOL STRING (case SYMBOL of
+ "jsFunc" => JsFunc STRING
+ | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+
+ffi_modes : ([])
+ | ffi_mode ffi_modes (ffi_mode :: ffi_modes)
diff --git a/src/urweb.lex b/src/urweb.lex
index 293c6dc6..15ae448e 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -445,6 +445,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
<INITIAL> "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext));
<INITIAL> "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext));
+<INITIAL> "ffi" => (Tokens.FFI (pos yypos, pos yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/activeEmpty.ur b/tests/activeEmpty.ur
new file mode 100644
index 00000000..4c089899
--- /dev/null
+++ b/tests/activeEmpty.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml><body>
+ <active code={alert "Howdy, neighbor!"; return <xml/>}/>
+ <hr/>
+ <active code={return <xml>This one <b>ain't</b> empty.</xml>}/>
+</body></xml>
diff --git a/tests/bindpat.ur b/tests/bindpat.ur
new file mode 100644
index 00000000..bca4bd41
--- /dev/null
+++ b/tests/bindpat.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+ (a, b) <- return (1, 2);
+ {C = c, ...} <- return {C = "hi", D = False};
+ d <- return 2.34;
+ {1 = e, 2 = f} <- return (8, 9);
+ return <xml>{[a]}, {[b]}, {[c]}, {[d]}, {[e]}, {[f]}</xml>
diff --git a/tests/data_attr.ur b/tests/data_attr.ur
new file mode 100644
index 00000000..80dda857
--- /dev/null
+++ b/tests/data_attr.ur
@@ -0,0 +1,26 @@
+fun dynd r = return <xml><body>
+ <div data={data_attr r.Attr r.Value}>How about that?</div>
+</body></xml>
+
+fun main () : transaction page =
+ s <- source <xml/>;
+ a <- source "";
+ v <- source "";
+ return <xml><body>
+ <div data-foo="hi" data-bar="bye" data-baz="why">Whoa there, cowboy!</div>
+
+ <hr/>
+
+ <form>
+ <textbox{#Attr}/> = <textbox{#Value}/>
+ <submit action={dynd}/>
+ </form>
+
+ <hr/>
+
+ <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>}/>
+ <hr/>
+ <dyn signal={signal s}/>
+ </body></xml>
diff --git a/tests/data_attr.urs b/tests/data_attr.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/data_attr.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/tests/dynClass.ur b/tests/dynClass.ur
index 37f931a2..7cb94d28 100644
--- a/tests/dynClass.ur
+++ b/tests/dynClass.ur
@@ -15,7 +15,7 @@ fun main () : transaction page =
STYLE "width: 500px"
else
STYLE "width: 200px")}
- onclick={b <- get toggle; set toggle (not b)}/>
+ onclick={fn _ => b <- get toggle; set toggle (not b)}/>
<button dynStyle={b <- signal toggle;
return (if b then
diff --git a/tests/dynList.ur b/tests/dynList.ur
new file mode 100644
index 00000000..09b3ee4c
--- /dev/null
+++ b/tests/dynList.ur
@@ -0,0 +1,22 @@
+fun main () =
+ b <- source True;
+ let
+ fun textboxList xs = <xml>
+ <table>
+ {List.mapX (fn src => <xml><tr>
+ <td dynClass={return null} dynStyle={b <- signal b;
+ if b then
+ return (STYLE "width: 500px")
+ else
+ return (STYLE "width: 100px")}>
+ <ctextbox source={src}/>
+ </td></tr></xml>) xs}
+ </table>
+ </xml>
+ in
+ s <- source "foo";
+ return <xml><body>
+ <ccheckbox source={b}/>
+ {textboxList (s :: s :: [])}
+ </body></xml>
+ end
diff --git a/tests/dynList.urp b/tests/dynList.urp
new file mode 100644
index 00000000..dc33cb28
--- /dev/null
+++ b/tests/dynList.urp
@@ -0,0 +1,4 @@
+rewrite all DynList/*
+
+$/list
+dynList
diff --git a/tests/dynList.urs b/tests/dynList.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/dynList.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/tests/lessSafeFfi.ur b/tests/lessSafeFfi.ur
new file mode 100644
index 00000000..da79bfdc
--- /dev/null
+++ b/tests/lessSafeFfi.ur
@@ -0,0 +1,19 @@
+ffi foo : int -> int
+ffi bar serverOnly benignEffectful : int -> transaction unit
+ffi baz : transaction int
+
+ffi bup jsFunc "jsbup" : int -> transaction unit
+
+fun other () : transaction page =
+ (*bar 17;
+ q <- baz;*)
+ return <xml><body>
+ (*{[foo 42]}, {[q]}*)
+ <button onclick={fn _ => bup 32}/>
+ </body></xml>
+
+fun main () = return <xml><body>
+ <form>
+ <submit action={other}/>
+ </form>
+</body></xml>
diff --git a/tests/lessSafeFfi.urp b/tests/lessSafeFfi.urp
new file mode 100644
index 00000000..729c5272
--- /dev/null
+++ b/tests/lessSafeFfi.urp
@@ -0,0 +1,5 @@
+rewrite all LessSafeFfi/*
+debug
+lessSafeFfi
+
+lessSafeFfi
diff --git a/tests/lessSafeFfi.urs b/tests/lessSafeFfi.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/lessSafeFfi.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/tests/thead.ur b/tests/thead.ur
new file mode 100644
index 00000000..a9774348
--- /dev/null
+++ b/tests/thead.ur
@@ -0,0 +1,16 @@
+fun main () : transaction page = return <xml><body>
+ <table>
+ <thead>
+ <tr> <th>A</th> <th>B</th> </tr>
+ </thead>
+
+ <tbody>
+ <tr> <td>1</td> <td>2</td> </tr>
+ <tr> <td>3</td> <td>4</td> </tr>
+ </tbody>
+
+ <tfoot>
+ <tr> <th>C</th> <th>D</th> </tr>
+ </tfoot>
+ </table>
+</body></xml>