From 640c7fe665f5f37fed005b2c9fe96c4818cc7043 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Wed, 26 Feb 2014 08:21:52 +0000 Subject: Define uw_loggers structure, allow FFI code to access it --- include/urweb/request.h | 11 +++++------ include/urweb/types_cpp.h | 6 ++++++ include/urweb/urweb_cpp.h | 6 ++++-- 3 files changed, 15 insertions(+), 8 deletions(-) (limited to 'include') 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 1bb6b2f2..b016f038 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); -- cgit v1.2.3 From 1e7619137f25ceb0cef59100bc5a41ffc21a1412 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 17 Apr 2014 17:41:24 -0400 Subject: uw_register_transactional() can return error codes --- doc/manual.tex | 6 +++--- include/urweb/urweb_cpp.h | 2 +- src/c/urweb.c | 7 +++++-- 3 files changed, 9 insertions(+), 6 deletions(-) (limited to 'include') diff --git a/doc/manual.tex b/doc/manual.tex index 98ebaac5..ea866309 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2459,10 +2459,10 @@ 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. 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. diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index b016f038..8e65ace3 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -280,7 +280,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 *); diff --git a/src/c/urweb.c b/src/c/urweb.c index 7417e4b7..9a1e40a7 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -3469,11 +3469,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; } @@ -3482,6 +3483,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; } -- cgit v1.2.3 From 1580340ec252e4e399c2c1d2b403974f49c3a084 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 2 May 2014 15:32:10 -0400 Subject: HTML5 data-* attributes --- doc/manual.tex | 6 ++-- include/urweb/urweb_cpp.h | 2 ++ lib/js/urweb.js | 13 ++++++++ lib/ur/basis.urs | 33 +++++++++++-------- src/c/urweb.c | 10 ++++++ src/mono_opt.sml | 10 ++++++ src/monoize.sml | 32 ++++++++++++++++++- src/settings.sml | 1 + src/urweb.grm | 81 ++++++++++++++++++++++++++++++++--------------- tests/data_attr.ur | 26 +++++++++++++++ tests/data_attr.urs | 1 + 11 files changed, 173 insertions(+), 42 deletions(-) create mode 100644 tests/data_attr.ur create mode 100644 tests/data_attr.urs (limited to 'include') diff --git a/doc/manual.tex b/doc/manual.tex index ea866309..2a65c906 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2052,7 +2052,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} @@ -2396,7 +2398,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. diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 8e65ace3..5a4411e8 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -387,6 +387,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 fe628130..ac9e9771 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1942,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 2525d676..4922e0ca 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 @@ -901,7 +907,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) @@ -935,12 +941,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] => @@ -1006,15 +1012,16 @@ val tfoot : other ::: {Unit} -> [other ~ [Table]] => unit 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/src/c/urweb.c b/src/c/urweb.c index 9a1e40a7..26046461 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4396,3 +4396,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/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 769a1e32..cdcd2bec 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) @@ -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 @@ -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"), _) => diff --git a/src/settings.sml b/src/settings.sml index 6282577d..4cdb4119 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -309,6 +309,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("checkUrl", "checkUrl"), ("bless", "bless"), + ("blessData", "blessData"), ("eq_time", "eq"), ("lt_time", "lt"), diff --git a/src/urweb.grm b/src/urweb.grm index 84a337f8..bb195cda 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -225,7 +225,7 @@ fun tagIn bt = datatype prop_kind = Delete | Update -datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp +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 @@ -453,7 +453,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 @@ -1602,7 +1602,31 @@ 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, pos)), pos) val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in @@ -1618,7 +1642,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 +1651,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 +1679,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)) 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 +
How about that?
+ + +fun main () : transaction page = + s <- source ; + a <- source ""; + v <- source ""; + return +
Whoa there, cowboy!
+ +
+ +
+ = + + + +
+ + = +