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

…ames (ocsigen#295)

CHANGES.md

@@ -2,7 +2,9 @@
 
 * Add support for `dialog` element and `onclose` attribute
   (#301 by Julien Sagot)
-
+* Add an escape hatch for emitting attributes with non-standard names
+  in jsx or ppx code (a leading `_` character on attribute name)
+  (#295 Chas @cemerick Emerick)
 * Add support for `type` attribute on `<script>` elements
   (#293 by Ulrik @ulrikstrid Strid and Chas @cemerick Emerick)
 

jsx/dune

@@ -11,4 +11,4 @@
          -open Ppxlib
          -w "-9"
  ))
-)
+)

syntax/attributes.ml

@@ -104,15 +104,28 @@ let parse loc (language, element_name) attributes =
           labeled, e::regular
         in
 
-        (* Check if this is a "data-foo" or "aria-foo" attribute. Parse the
-           attribute value, and accumulate it in the list of attributes passed
+        (* Check if this is a "data-foo", "aria-foo", or unsafe attribute. Parse
+           the 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 ->
+          let value =
+            match value with
+            | Val s -> s
+            | Antiquot _ ->
+              Common.error loc
+              "Internal error: unsafe string attribute %s has a non-string value"
+              tag in
+          let value = Common.string loc value in
+          let identifier = Common.make ~loc language "Unsafe.string_attrib" in
+          let tag = Common.string loc tag in
+          labeled, [%expr [%e identifier] [%e tag] [%e value]] :: regular
+        | 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=[Unsafe.string_attrib("some-attr", "value")], Xml.W.nil ())],
+      ),
     ]
   ),
 );

test/test_ppx.ml

@@ -283,6 +283,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:[Unsafe.string_attrib "some-attr" "value"] []]
+
 ]
 
 let ns_nesting = "namespace nesting" , HtmlTests.make Html.[