'aria-*' attributes

5 files changed, 24 insertions, 12 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 32ed9fc2..0550d081 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2065,7 +2065,7 @@ $$\begin{array}{l}
 
 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.
+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, and the same mechanism is reused to support \texttt{aria-*} attributes.
 
 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}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index ce8ed91f..8efed25b 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -797,9 +797,13 @@ val active : unit
 val script : unit
              -> tag [Code = transaction unit] head [] [] []
 
-(* Type for HTML5 "data-*" attributes. *)
+(* Type for HTML5 "data-*" and "aria-*" attributes. *)
+type data_attr_kind
+val data_kind : data_attr_kind
+val aria_kind : data_attr_kind
+
 type data_attr
-val data_attr : string (* Key *) -> string (* Value *) -> data_attr
+val data_attr : data_attr_kind -> 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
 
diff --git a/src/monoize.sml b/src/monoize.sml
index a639f4a6..9182c077 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -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_kind") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
 
                   | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
@@ -3122,12 +3123,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
-          | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) =>
+          | L.EFfi ("Basis", "data_kind") => ((L'.EPrim (Prim.String "data-"), loc), fm)
+          | L.EFfi ("Basis", "aria_kind") => ((L'.EPrim (Prim.String "aria-"), loc), fm)
+
+          | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) =>
             let
+                val (sk, fm) = monoExp (env, st, fm) sk
                 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 (sk,
                               (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),
diff --git a/src/urweb.grm b/src/urweb.grm
index 1f4540ba..862debc5 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 | Data of string * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * string * exp
 
 fun patType loc (p : pat) =
     case #1 p of
@@ -486,7 +486,7 @@ fun patternOut (e : exp) =
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (string * string * exp) list * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1652,9 +1652,10 @@ tag    : tagHead attrs                  (let
                                                             [] => #6 attrs
                                                           | data :: datas =>
                                                             let
-                                                                fun doOne (name, value) =
+                                                                fun doOne (kind, name, value) =
                                                                     let
                                                                         val e = (EVar (["Basis"], "data_attr", Infer), pos)
+                                                                        val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos)
                                                                         val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
                                                                     in
                                                                         (EApp (e, value), pos)
@@ -1725,7 +1726,9 @@ attr   : SYMBOL EQ attrv                (case SYMBOL of
 					   | "dynStyle" => DynStyle attrv
 					   | _ =>
                                              if String.isPrefix "data-" SYMBOL then
-                                                 Data (String.extract (SYMBOL, 5, NONE), attrv)
+                                                 Data ("data", String.extract (SYMBOL, 5, NONE), attrv)
+                                             else if String.isPrefix "aria-" SYMBOL then
+                                                 Data ("aria", String.extract (SYMBOL, 5, NONE), attrv)
                                              else
                                                  let
                                                      val sym = makeAttr SYMBOL
diff --git a/tests/data_attr.ur b/tests/data_attr.ur
index 80dda857..4462dc10 100644
--- a/tests/data_attr.ur
+++ b/tests/data_attr.ur
@@ -1,5 +1,5 @@
 fun dynd r = return <xml><body>
-  <div data={data_attr r.Attr r.Value}>How about that?</div>
+  <div data={data_attr data_kind r.Attr r.Value}>How about that?</div>
 </body></xml>
 
 fun main () : transaction page =
@@ -7,7 +7,7 @@ fun main () : transaction page =
   a <- source "";
   v <- source "";
   return <xml><body>
-    <div data-foo="hi" data-bar="bye" data-baz="why">Whoa there, cowboy!</div>
+    <div data-foo="hi" aria-something="wow" data-bar="bye" data-baz="why">Whoa there, cowboy!</div>
 
     <hr/>
 
@@ -20,7 +20,7 @@ fun main () : transaction page =
 
     <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>}/>
+      a <- get a; v <- get v; set s <xml><div data={data_attr data_kind a v}>OHO!</div></xml>}/>
     <hr/>
     <dyn signal={signal s}/>
   </body></xml>