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 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!
+ +
+ +
+ = + + + +
+ + = +