From 83a42d113f86b4756619e80aff12c2db2069f5d2 Mon Sep 17 00:00:00 2001
From: Chas Emerick <chas@cemerick.com>
Date: Wed, 12 Jan 2022 13:56:23 -0500
Subject: [PATCH] implement an escape hatch for emitting attributes with
 non-standard names (#295)

---
 CHANGES.md                |  4 +++-
 docs/manual-wiki/jsx.wiki | 21 +++++++++++++++++++++
 docs/manual-wiki/ppx.wiki | 21 +++++++++++++++++++++
 jsx/dune                  |  2 +-
 jsx/tyxml_jsx.ml          | 36 ++++++++++++++++++++----------------
 syntax/attributes.ml      | 20 ++++++++++++++------
 test/test_jsx.re          | 10 ++++++++++
 test/test_ppx.ml          |  6 ++++++
 8 files changed, 96 insertions(+), 24 deletions(-)

diff --git a/CHANGES.md b/CHANGES.md
index b77ca3fc1..31f3b5d82 100644
--- a/CHANGES.md
+++ b/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)
 
diff --git a/docs/manual-wiki/jsx.wiki b/docs/manual-wiki/jsx.wiki
index f7dc2d290..0333b37fa 100644
--- a/docs/manual-wiki/jsx.wiki
+++ b/docs/manual-wiki/jsx.wiki
@@ -80,6 +80,27 @@ version in <<a_api project="js_of_ocaml" subproject="js_of_ocaml-tyxml" | Js_of_
 
 In each case, simply open the module and the JSX syntax will use it.
 
+==@@id="unsafe"@@ "Unsafe" attributes
+
+Some Javascript libraries and frameworks depend upon HTML markup that includes non-standard
+attributes, which tyxml would usually reject. When constructing elements using tyxml's API directly,
+the available workaround is to use the <<a_api text="Unsafe"|val Html_sigs.T.Unsafe>> constructors.
+The same relaxed semantics can be had when using JSX by prefixing non-standard attribute names
+with a leading underscore.
+
+So, while this will fail:
+<<code language="ocaml"|
+let button = <button hx_post="/clicked" hx_swap="outerHTML">Click Me</button>
+>>
+
+This will not:
+<<code language="ocaml"|
+let button = <button _hx_post="/clicked" _hx_swap="outerHTML">Click Me</button>
+>>
+
+Such underscore-prefixed attributes are presumed to be strings, and are constructed using e.g.
+<<a_api text="Unsafe.string_attrib"|val Html_sigs.T.Unsafe.string_attrib>>.
+
 ==@@id="tips"@@ Tips
 
 It can sometime be necessary to disable the JSX syntax. For that purpose, simply use the toogle `[@tyxml.jsx false]` to turn the JSX on and off.
diff --git a/docs/manual-wiki/ppx.wiki b/docs/manual-wiki/ppx.wiki
index ab1326c98..1e2d1923b 100644
--- a/docs/manual-wiki/ppx.wiki
+++ b/docs/manual-wiki/ppx.wiki
@@ -59,6 +59,27 @@ let my_div = [%html "<div id="my_id"></div>"]
 val my_div : [> Html_types.div ] Html.elt
 >>
 
+==@@id="unsafe"@@ "Unsafe" attributes
+
+Some Javascript libraries and frameworks depend upon HTML markup that includes non-standard
+attributes, which tyxml would usually reject. When constructing elements using tyxml's API directly,
+the available workaround is to use the <<a_api text="Unsafe"|val Html_sigs.T.Unsafe>> constructors.
+The same relaxed semantics can be had when using the ppx by prefixing non-standard attribute names
+with a leading underscore.
+
+So, while this will fail:
+<<code language="ocaml"|
+[%html {|<button hx_post="/clicked" hx_swap="outerHTML">Click Me</button>|}]
+>>
+
+This will not:
+<<code language="ocaml"|
+[%html {|<button _hx_post="/clicked" _hx_swap="outerHTML">Click Me</button>|}]
+>>
+
+Such underscore-prefixed attributes are presumed to be strings, and are constructed using e.g.
+<<a_api text="Unsafe.string_attrib"|val Html_sigs.T.Unsafe.string_attrib>>.
+
 ==@@id="let"@@ Let notation
 
 It is also possible to use the ppx with the ##let## notation:
diff --git a/jsx/dune b/jsx/dune
index 90f709dfc..31a02b766 100644
--- a/jsx/dune
+++ b/jsx/dune
@@ -11,4 +11,4 @@
          -open Ppxlib
          -w "-9"
  ))
-)
+)
\ No newline at end of file
diff --git a/jsx/tyxml_jsx.ml b/jsx/tyxml_jsx.ml
index 0806efb31..2fd71e746 100644
--- a/jsx/tyxml_jsx.ml
+++ b/jsx/tyxml_jsx.ml
@@ -22,23 +22,27 @@ end
 let lowercase_lead s =
   String.mapi (fun i c -> if i = 0 then Char.lowercase_ascii c else c) s
 
-let to_kebab_case name =
+let to_kebab_case =
   let open Re in
-  let kebab string =
-    replace (Posix.compile_pat "[A-Z]") ~f:(fun g -> "-" ^ Group.get g 0) string
-    |> String.lowercase_ascii
-    |> replace_string (compile @@ char '_') ~by:"-" in
-  match exec_opt (Perl.compile_pat {|^(data_?|aria_?)(.+)|}) name with
-  | None -> 
-    if name.[0] == '_'
-    (* need to keep the leading underscore, as that's what the syntax support keys
-       off of to know to use Unsafe.string_attrib *)
-    then "_" ^ kebab @@ String.sub name 1 (String.length name - 1)
-    else name
-  | Some g ->
-    let prefix = String.sub name 0 4 in
-    let suffix = kebab @@ Group.get g 2 in
-    prefix ^ (if suffix.[0] == '-' then "" else "-") ^ suffix
+  let camelPat = Posix.compile_pat "[A-Z]" in
+  let underscore = compile @@ char '_' in
+  let prefixes = Perl.compile_pat {|^(data_?|aria_?)(.+)|} in
+  fun name ->
+    let kebab string =
+      replace camelPat ~f:(fun g -> "-" ^ Group.get g 0) string
+      |> String.lowercase_ascii
+      |> replace_string underscore ~by:"-" in
+    match exec_opt prefixes name with
+    | None -> 
+      if name.[0] == '_'
+      (* need to keep the leading underscore, as that's what the syntax support keys
+         off of to know to use Unsafe.string_attrib *)
+      then "_" ^ kebab @@ String.sub name 1 (String.length name - 1)
+      else name
+    | Some g ->
+      let prefix = String.sub name 0 4 in
+      let suffix = kebab @@ Group.get g 2 in
+      prefix ^ (if suffix.[0] == '-' then "" else "-") ^ suffix
 
 let make_attr_name name =
   let name =
diff --git a/syntax/attributes.ml b/syntax/attributes.ml
index 678dec5a0..85177bf2d 100644
--- a/syntax/attributes.ml
+++ b/syntax/attributes.ml
@@ -104,15 +104,23 @@ 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 identifier = Common.make ~loc language "Unsafe.string_attrib" in
+          let tag = Common.string loc tag in
+          let value = match value with
+                      | Val s -> Common.string loc s
+                      | Antiquot v -> v 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
diff --git a/test/test_jsx.re b/test/test_jsx.re
index 94dac1291..ea40aa7d1 100644
--- a/test/test_jsx.re
+++ b/test/test_jsx.re
@@ -173,6 +173,16 @@ 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 ())],
+      ),
+      ( "arbitrary (unchecked) attributes via an escape hatch, with antiquotation",
+        [<div _some_attr={"val" ++ "ue"}/>],
+        // 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 ())],
+      ),
     ]
   ),
 );
diff --git a/test/test_ppx.ml b/test/test_ppx.ml
index cbdec1c89..ecb1c8a49 100644
--- a/test/test_ppx.ml
+++ b/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.[