implement an escape hatch for emitting attributes with non-standard n…

…ames (ocsigen#295)

CHANGES.md

@@ -1,5 +1,8 @@
 # NEXT
 
+* Add an escape hatch for emitting attributes with non-standard names
+  (`a_unchecked`, or a leading `_` character on attribute name in jsx or ppx code)
+  (#295 Chas @cemerick Emerick)
 * Add support for `type` attribute on `<script>` elements
   (#293 by Ulrik @ulrikstrid Strid and Chas @cemerick Emerick)
 

jsx/tyxml_jsx.ml

@@ -24,14 +24,20 @@ let lowercase_lead s =
 
 let to_kebab_case name =
   let open Str in
+  let kebab string =
+    Str.global_replace (regexp "[A-Z]") "-\\0" string
+    |> String.lowercase_ascii
+    |> Str.global_replace (regexp "_") "-" in
   if Str.(string_match (regexp {|^\(data_?\|aria_?\)\(.+\)|}) name 0)
   then let prefix = String.sub name 0 4 in
-       let suffix = Str.matched_group 2 name
-                 |> Str.global_replace (regexp "[A-Z]") "-\\0" 
-                 |> String.lowercase_ascii
-                 |> Str.global_replace (regexp "_") "-" in
+       let suffix = kebab @@ Str.matched_group 2 name in
        prefix ^ (if suffix.[0] == '-' then "" else "-") ^ suffix
-  else name
+  else if name.[0] == '_'
+       (* need to keep the leading underscore, as that's what the syntax support keys
+          off of to know to use a_unchecked *)
+       then "_" ^ kebab @@ String.sub name 1 (String.length name - 1)
+       else name
+
 
 let make_attr_name name =
   let name =

lib/html_f.ml

@@ -98,6 +98,8 @@ struct
 
   let a_user_data name = string_attrib ("data-" ^ name)
 
+  let a_unchecked name = string_attrib name
+
   let a_title = string_attrib "title"
 
   (* I18N: *)

lib/html_sigs.mli

@@ -143,6 +143,9 @@ module type T = sig
   <li data-length="2m11s">Beyond The Sea</li>
 </ol> v}
       It should be used for preprocessing ends only. *)
+
+  val a_unchecked : nmtoken -> text wrap -> [> | `Unchecked] attrib
+  (** An "escape hatch" for emitting non-standard attributes. *)
 
   val a_id : text wrap -> [> | `Id] attrib
   (** This attribute assigns a name to an element. This name must be

lib/html_types.mli

@@ -279,6 +279,7 @@ type core =
     | `Translate
     | `Title
     | `User_data
+    | `Unchecked
     | `XMLns
   ]
 

syntax/attributes.ml

@@ -108,11 +108,13 @@ let parse loc (language, element_name) attributes =
            attribute value, and accumulate it in the list of attributes passed
            in ~a. *)
         match parse_prefixed "data-" local_name,
-              parse_prefixed "aria-" local_name
+              parse_prefixed "aria-" local_name,
+              parse_prefixed "_" local_name
         with
-        | Some tag, _ -> parse_prefixed_attribute tag "a_user_data"
-        | _, Some tag -> parse_prefixed_attribute tag "a_aria"
-        | None, None ->
+        | Some tag, _, _ -> parse_prefixed_attribute tag "a_user_data"
+        | _, Some tag, _ -> parse_prefixed_attribute tag "a_aria"
+        | _, _, Some tag -> parse_prefixed_attribute tag "a_unchecked"
+        | None, None, None ->
           let tyxml_name =
             match Common.find test_renamed Reflected.renamed_attributes with
             | Some (name, _, _) -> name

test/test_jsx.re

@@ -173,6 +173,11 @@ let attribs = (
         // the Xml.W.nil is here to satisfy the internal structure of what the jsx ppx produces
         [div(~a=[a_user_data("foo-bar", "baz")], Xml.W.nil ())],
       ),
+      ( "arbitrary (unchecked) attributes via an escape hatch",
+        [<div _some_attr="value"/>],
+        // the Xml.W.nil is here to satisfy the internal structure of what the jsx ppx produces
+        [div(~a=[a_unchecked("some-attr", "value")], Xml.W.nil ())],
+      ),
     ]
   ),
 );

test/test_ppx.ml

@@ -279,6 +279,12 @@ let attribs = "ppx attribs", HtmlTests.make Html.[
   [[%html "<div data-foo='valfoo'></div>"]],
   [div
     ~a:[a_user_data "foo" "valfoo"] []] ;
+
+  "arbitrary (unchecked) attributes via an escape hatch",
+  [[%html "<div _some-attr='value'></div>"]],
+  [div
+    ~a:[a_unchecked "some-attr" "value"] []]
+
 ]
 
 let ns_nesting = "namespace nesting" , HtmlTests.make Html.[