HTML5 data-* attributes

11 files changed, 173 insertions, 42 deletions

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 <xml><body>
+  <div data={data_attr r.Attr r.Value}>How about that?</div>
+</body></xml>
+
+fun main () : transaction page =
+  s <- source <xml/>;
+  a <- source "";
+  v <- source "";
+  return <xml><body>
+    <div data-foo="hi" data-bar="bye" data-baz="why">Whoa there, cowboy!</div>
+
+    <hr/>
+
+    <form>
+      <textbox{#Attr}/> = <textbox{#Value}/>
+      <submit action={dynd}/>
+    </form>
+
+    <hr/>
+
+    <ctextbox source={a}/> = <ctextbox source={v}/>
+    <button onclick={fn _ =>
+      a <- get a; v <- get v; set s <xml><div data={data_attr a v}>OHO!</div></xml>}/>
+    <hr/>
+    <dyn signal={signal s}/>
+  </body></xml>
diff --git a/tests/data_attr.urs b/tests/data_attr.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/data_attr.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page