Mercurial > urweb
changeset 2206:c1a62ce47083
Merge.
| author | Ziv Scully <ziv@mit.edu> |
|---|---|
| date | Tue, 27 May 2014 21:38:01 -0400 |
| parents | cdea39473c78 3ed2ee0815d2 |
| children | f0f7bf234893 |
| files | include/urweb/urweb_cpp.h src/c/urweb.c src/compiler.sml |
| diffstat | 54 files changed, 825 insertions(+), 228 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Tue May 27 21:15:53 2014 -0400 +++ b/CHANGELOG Tue May 27 21:38:01 2014 -0400 @@ -1,3 +1,17 @@ +======== +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 ========
--- a/configure.ac Tue May 27 21:15:53 2014 -0400 +++ b/configure.ac Tue May 27 21:38:01 2014 -0400 @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20131231]) +AC_INIT([urweb], [20140426]) WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS
--- a/doc/manual.tex Tue May 27 21:15:53 2014 -0400 +++ b/doc/manual.tex Tue May 27 21:38:01 2014 -0400 @@ -62,6 +62,8 @@ 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 @@ 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 @@ \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 @@ 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 @@ \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 @@ \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 @@ \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. - - 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. + 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. 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 @@ \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 @@ 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}
--- a/include/urweb/request.h Tue May 27 21:15:53 2014 -0400 +++ b/include/urweb/request.h Tue May 27 21:38:01 2014 -0400 @@ -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 @@ 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);
--- a/include/urweb/types_cpp.h Tue May 27 21:15:53 2014 -0400 +++ b/include/urweb/types_cpp.h Tue May 27 21:38:01 2014 -0400 @@ -106,6 +106,12 @@ 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 {
--- a/include/urweb/urweb_cpp.h Tue May 27 21:15:53 2014 -0400 +++ b/include/urweb/urweb_cpp.h Tue May 27 21:38:01 2014 -0400 @@ -14,13 +14,13 @@ 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 @@ 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_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_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
--- a/lib/js/urweb.js Tue May 27 21:15:53 2014 -0400 +++ b/lib/js/urweb.js Tue May 27 21:38:01 2014 -0400 @@ -1009,8 +1009,6 @@ if (suspendScripts) return; - var span = document.createElement("span"); - addNode(span); var ms = maySuspend; maySuspend = false; try { @@ -1020,7 +1018,11 @@ 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 @@ return x; } -function dynClass(html, s_class, s_style) { +function dynClass(pnode, html, s_class, s_style) { if (suspendScripts) return; @@ -1119,7 +1121,7 @@ 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 @@ 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; + var y = document.createElement("script"); + y.dead = false; + y.signal = s_style; + y.sources = null; + y.closures = htmlCls2; - x.recreate = function(v) { - for (var ls = x.closures; ls != htmlCls2; ls = ls.next) + 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 @@ } +// 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) {
--- a/lib/ur/basis.urs Tue May 27 21:15:53 2014 -0400 +++ b/lib/ur/basis.urs Tue May 27 21:38:01 2014 -0400 @@ -796,11 +796,17 @@ 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 @@ -> [[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 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 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 @@ -> [[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 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 @@ -> 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 *)
--- a/lib/ur/top.urs Tue May 27 21:15:53 2014 -0400 +++ b/lib/ur/top.urs Tue May 27 21:38:01 2014 -0400 @@ -155,6 +155,10 @@ -> 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
--- a/src/c/cgi.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/cgi.c Tue May 27 21:38:01 2014 -0400 @@ -60,8 +60,10 @@ 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 @@ 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,
--- a/src/c/fastcgi.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/fastcgi.c Tue May 27 21:38:01 2014 -0400 @@ -324,7 +324,8 @@ 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 @@ 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 @@ } 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 @@ { 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; }
--- a/src/c/http.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/http.c Tue May 27 21:38:01 2014 -0400 @@ -70,9 +70,11 @@ } } +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 @@ 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 @@ } } - 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 @@ { 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; }
--- a/src/c/request.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/request.c Tue May 27 21:38:01 2014 -0400 @@ -12,6 +12,7 @@ #include <pthread.h> #include "urweb.h" +#include "request.h" #define MAX_RETRIES 5 @@ -32,8 +33,11 @@ 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 @@ } typedef struct { + int id; + uw_loggers *ls; + uw_periodic pdic; uw_app *app; - void *logger_data; - uw_logger log_error, log_debug; -} loggers; - -typedef struct { - int id; - loggers *ls; - uw_periodic pdic; } 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 @@ } } -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 @@ } } - 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 @@ } } - 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 @@ 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 @@ 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 @@ } 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);
--- a/src/c/static.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/static.c Tue May 27 21:38:01 2014 -0400 @@ -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 @@ return 1; } - ctx = uw_init(0, NULL, log_debug); + ctx = uw_init(0, &loggers); uw_set_app(ctx, &uw_application); uw_initialize(ctx);
--- a/src/c/urweb.c Tue May 27 21:15:53 2014 -0400 +++ b/src/c/urweb.c Tue May 27 21:38:01 2014 -0400 @@ -460,8 +460,7 @@ 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_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 @@ 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 @@ 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 @@ 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); - - if (result) + int error = posix_memalign(&result, 4, len); + + 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_begin_region(uw_context ctx) { + align_heap(ctx); + regions *r = (regions *) ctx->heap.front; uw_check_heap(ctx, sizeof(regions)); @@ -1588,6 +1610,9 @@ 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 @@ } } + if (ctx->transaction_started) { + int code = ctx->app->db_commit(ctx); + + if (code) { + 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); + + 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)) { - uw_rollback(ctx, 0); + 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; } } - if (ctx->transaction_started) { - int code = ctx->app->db_commit(ctx); - - if (code) { - if (code == -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); - - uw_set_error_message(ctx, "Error running SQL COMMIT"); - 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 @@ 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 @@ 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_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_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 @@ 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; +}
--- a/src/compiler.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/compiler.sml Tue May 27 21:38:01 2014 -0400 @@ -874,6 +874,7 @@ | "timeFormat" => Settings.setTimeFormat arg | "noMangleSql" => Settings.setMangleSql false | "html5" => Settings.setIsHtml5 true + | "lessSafeFfi" => Settings.setLessSafeFfi true | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read ()
--- a/src/corify.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/corify.sml Tue May 27 21:38:01 2014 -0400 @@ -643,6 +643,12 @@ | 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 @@ 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 @@ ([], 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 @@ | 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, _) =
--- a/src/elab.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elab.sml Tue May 27 21:38:01 2014 -0400 @@ -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 @@ | 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
--- a/src/elab_env.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elab_env.sml Tue May 27 21:38:01 2014 -0400 @@ -1681,5 +1681,6 @@ | DTask _ => env | DPolicy _ => env | DOnError _ => env + | DFfi (x, n, _, t) => pushENamedAs env x n t end
--- a/src/elab_err.sig Tue May 27 21:15:53 2014 -0400 +++ b/src/elab_err.sig Tue May 27 21:38:01 2014 -0400 @@ -81,6 +81,7 @@ | 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
--- a/src/elab_err.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elab_err.sml Tue May 27 21:38:01 2014 -0400 @@ -180,6 +180,7 @@ | 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 @@ (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 =
--- a/src/elab_print.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elab_print.sml Tue May 27 21:38:01 2014 -0400 @@ -852,6 +852,7 @@ space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of
--- a/src/elab_util.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elab_util.sml Tue May 27 21:38:01 2014 -0400 @@ -927,7 +927,8 @@ 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 @@ 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 @@ | DTask _ => 0 | DPolicy _ => 0 | DOnError _ => 0 + | DFfi (_, n, _, _) => n and maxNameStr (str, _) = case str of StrConst ds => maxName ds
--- a/src/elaborate.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/elaborate.sml Tue May 27 21:38:01 2014 -0400 @@ -2183,8 +2183,13 @@ (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 @@ | 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 @@ ([(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),
--- a/src/elisp/urweb-mode.el Tue May 27 21:15:53 2014 -0400 +++ b/src/elisp/urweb-mode.el Tue May 27 21:38:01 2014 -0400 @@ -139,7 +139,7 @@ "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.")
--- a/src/expl.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/expl.sml Tue May 27 21:38:01 2014 -0400 @@ -150,6 +150,7 @@ | 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
--- a/src/expl_env.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/expl_env.sml Tue May 27 21:38:01 2014 -0400 @@ -346,6 +346,7 @@ | DTask _ => env | DPolicy _ => env | DOnError _ => env + | DFfi (x, n, _, t) => pushENamed env x n t fun sgiBinds env (sgi, loc) = case sgi of
--- a/src/expl_print.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/expl_print.sml Tue May 27 21:38:01 2014 -0400 @@ -731,6 +731,7 @@ space, p_exp env e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str env (str, _) = case str of
--- a/src/expl_rename.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/expl_rename.sml Tue May 27 21:38:01 2014 -0400 @@ -219,6 +219,7 @@ (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 @@ (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
--- a/src/explify.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/explify.sml Tue May 27 21:38:01 2014 -0400 @@ -198,6 +198,7 @@ | 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
--- a/src/jscomp.sig Tue May 27 21:15:53 2014 -0400 +++ b/src/jscomp.sig Tue May 27 21:38:01 2014 -0400 @@ -29,4 +29,8 @@ 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
--- a/src/jscomp.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/jscomp.sml Tue May 27 21:38:01 2014 -0400 @@ -41,6 +41,8 @@ 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 @@ ((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 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 =
--- a/src/main.mlton.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/main.mlton.sml Tue May 27 21:38:01 2014 -0400 @@ -174,6 +174,9 @@ 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)
--- a/src/mono_opt.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/mono_opt.sml Tue May 27 21:38:01 2014 -0400 @@ -118,6 +118,9 @@ 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 @@ | 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 ()
--- a/src/monoize.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/monoize.sml Tue May 27 21:38:01 2014 -0400 @@ -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 @@ | 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 @@ strcatComma (map (fn (x', _) => sc ("T_" ^ x - ^ "" + ^ "." ^ Settings.mangleSql x')) xts)) grouped) ], @@ -3117,6 +3118,29 @@ 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 @@ (L.ECApp ( (L.ECApp ( (L.EFfi ("Basis", "tag"), - _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), ctxOuter), _), _), _), _), _), _), _), _), _), _), _), class), _), dynClass), _), style), _), @@ -3317,6 +3341,12 @@ 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 @@ (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 @@ | "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 @@ 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 @@ | _ => (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),
--- a/src/settings.sig Tue May 27 21:15:53 2014 -0400 +++ b/src/settings.sig Tue May 27 21:38:01 2014 -0400 @@ -78,18 +78,22 @@ (* 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 @@ val setIsHtml5 : bool -> unit val getIsHtml5 : unit -> bool + + val setLessSafeFfi : bool -> unit + val getLessSafeFfi : unit -> bool end
--- a/src/settings.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/settings.sml Tue May 27 21:38:01 2014 -0400 @@ -194,6 +194,7 @@ 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 @@ "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 @@ "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 @@ ("checkUrl", "checkUrl"), ("bless", "bless"), + ("blessData", "blessData"), ("eq_time", "eq"), ("lt_time", "lt"), @@ -363,6 +367,7 @@ 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 @@ fun setIsHtml5 b = html5 := b fun getIsHtml5 () = !html5 +val less = ref false +fun setLessSafeFfi b = less := b +fun getLessSafeFfi () = !less + end
--- a/src/source.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/source.sml Tue May 27 21:38:01 2014 -0400 @@ -125,7 +125,7 @@ | 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 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 @@ | 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
--- a/src/source_print.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/source_print.sml Tue May 27 21:38:01 2014 -0400 @@ -277,14 +277,20 @@ 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 @@ space, p_exp e1] | DOnError _ => string "ONERROR" + | DFfi _ => string "FFI" and p_str (str, _) = case str of
--- a/src/unnest.sml Tue May 27 21:15:53 2014 -0400 +++ b/src/unnest.sml Tue May 27 21:38:01 2014 -0400 @@ -452,6 +452,7 @@ | DTask _ => explore () | DPolicy _ => explore () | DOnError _ => default () + | DFfi _ => default () end and doStr (all as (str, loc), st) =
--- a/src/urweb.grm Tue May 27 21:15:53 2014 -0400 +++ b/src/urweb.grm Tue May 27 21:38:01 2014 -0400 @@ -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 @@ 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 @@ (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 @@ | 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 @@ | 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 @@ | 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 @@ | 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 @@ | 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ ^ " 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 @@ 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 @@ 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 @@ | 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 @@ 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 @@ (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 @@ | "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 @@ 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 @@ 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 @@ 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 @@ | 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)
--- a/src/urweb.lex Tue May 27 21:15:53 2014 -0400 +++ b/src/urweb.lex Tue May 27 21:38:01 2014 -0400 @@ -445,6 +445,7 @@ <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));
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/activeEmpty.ur Tue May 27 21:38:01 2014 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/bindpat.ur Tue May 27 21:38:01 2014 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/data_attr.ur Tue May 27 21:38:01 2014 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/data_attr.urs Tue May 27 21:38:01 2014 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/tests/dynClass.ur Tue May 27 21:15:53 2014 -0400 +++ b/tests/dynClass.ur Tue May 27 21:38:01 2014 -0400 @@ -15,7 +15,7 @@ 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dynList.ur Tue May 27 21:38:01 2014 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dynList.urp Tue May 27 21:38:01 2014 -0400 @@ -0,0 +1,4 @@ +rewrite all DynList/* + +$/list +dynList
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/dynList.urs Tue May 27 21:38:01 2014 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/lessSafeFfi.ur Tue May 27 21:38:01 2014 -0400 @@ -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>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/lessSafeFfi.urp Tue May 27 21:38:01 2014 -0400 @@ -0,0 +1,5 @@ +rewrite all LessSafeFfi/* +debug +lessSafeFfi + +lessSafeFfi
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/lessSafeFfi.urs Tue May 27 21:38:01 2014 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/thead.ur Tue May 27 21:38:01 2014 -0400 @@ -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>