diff --git a/ppx/dom_props.ml b/ppx/dom_props.ml
new file mode 100644
index 000000000..ec00b4b67
--- /dev/null
+++ b/ppx/dom_props.ml
@@ -0,0 +1,176 @@
+open Ppxlib
+open Ast_builder.Default
+
+let attribute ~loc name payload =
+ attribute ~loc ~name:{ txt = name; loc } ~payload
+
+let data_attribute name =
+ if
+ String.length name > 4
+ && String.sub name 0 4 = "data"
+ && name.[4] >= 'A'
+ && name.[4] <= 'Z'
+ then (
+ let buffer = Buffer.create (String.length name + 4) in
+ String.iter
+ (function
+ | 'A' .. 'Z' as c ->
+ Buffer.add_char buffer '-';
+ Buffer.add_char buffer (Char.lowercase_ascii c)
+ | c -> Buffer.add_char buffer c)
+ name;
+ Some (Buffer.contents buffer))
+ else None
+
+(* These are the [mel.as] conventions used by ReactDOM.domProps. Ordinary
+ React prop names, such as className and onClick, keep their spelling. *)
+let js_name name =
+ match name with
+ | "as_" | "begin_" | "end_" | "in_" | "open_" | "to_" | "type_" ->
+ Some (String.sub name 0 (String.length name - 1))
+ | _ when String.length name > 4 && String.sub name 0 4 = "aria" ->
+ Some
+ ("aria-"
+ ^ String.lowercase_ascii (String.sub name 4 (String.length name - 4)))
+ | _ -> None
+
+let label_name = function
+ | Labelled name | Optional name -> name
+ | Nolabel -> ""
+
+let make ~loc ~dom_props args =
+ if
+ not
+ (List.exists
+ (fun (label, _) -> Option.is_some (data_attribute (label_name label)))
+ args)
+ then dom_props args
+ else
+ let ghost_loc = { loc with loc_ghost = true } in
+ let unit_type =
+ ptyp_constr ~loc:ghost_loc { txt = Lident "unit"; loc } []
+ in
+ let props_type =
+ ptyp_constr ~loc:ghost_loc
+ { txt = Ldot (Lident "ReactDOM", "domProps"); loc }
+ []
+ in
+ let props =
+ List.mapi
+ (fun index (label, expression) ->
+ let name = "prop" ^ string_of_int index in
+ let data_name = data_attribute (label_name label) in
+ let type_ =
+ match (label, data_name) with
+ | Nolabel, _ -> unit_type
+ | _, Some _ ->
+ ptyp_constr ~loc:ghost_loc { txt = Lident "string"; loc } []
+ | _, None -> ptyp_var ~loc:ghost_loc name
+ in
+ (label, expression, name, type_, data_name))
+ args
+ in
+ let ordinary_props =
+ List.filter (fun (_, _, _, _, data_name) -> data_name = None) props
+ in
+ let arrow (label, _, _, type_, _) result =
+ ptyp_arrow ~loc:ghost_loc label type_ result
+ in
+ (* The shared type variables connect each supplied prop to the corresponding
+ argument of ReactDOM.domProps. Melange erases this pure callback after
+ OCaml has checked both its labels and its types. *)
+ let check_type = List.fold_right arrow ordinary_props props_type in
+ let check_type =
+ {
+ check_type with
+ ptyp_attributes = [ attribute ~loc:ghost_loc "mel.ignore" (PStr []) ];
+ }
+ in
+ let check_args =
+ List.map
+ (fun (label, expression, name, _, _) ->
+ let loc = { expression.pexp_loc with loc_ghost = true } in
+ let arg =
+ match label with
+ | Nolabel -> pexp_construct ~loc { txt = Lident "()"; loc } None
+ | Labelled _ | Optional _ ->
+ pexp_ident ~loc { txt = Lident name; loc }
+ in
+ (label, arg))
+ ordinary_props
+ in
+ let check =
+ List.fold_right
+ (fun (label, _, name, _, _) body ->
+ let pattern =
+ match label with
+ | Nolabel ->
+ ppat_construct ~loc:ghost_loc { txt = Lident "()"; loc } None
+ | Labelled _ | Optional _ ->
+ ppat_var ~loc:ghost_loc { txt = name; loc = ghost_loc }
+ in
+ pexp_fun ~loc:ghost_loc label None pattern body)
+ ordinary_props (dom_props check_args)
+ in
+ let check =
+ {
+ check with
+ pexp_attributes = [ attribute ~loc:ghost_loc "merlin.hide" (PStr []) ];
+ }
+ in
+ let make_type =
+ List.fold_right
+ (fun (label, _, _, type_, data_name) result ->
+ let name =
+ match data_name with
+ | Some _ -> data_name
+ | None -> js_name (label_name label)
+ in
+ let type_ =
+ match name with
+ | None -> type_
+ | Some name ->
+ {
+ type_ with
+ ptyp_attributes =
+ [
+ attribute ~loc:ghost_loc "mel.as"
+ (PStr
+ [
+ pstr_eval ~loc:ghost_loc
+ (estring ~loc:ghost_loc name)
+ [];
+ ]);
+ ];
+ }
+ in
+ ptyp_arrow ~loc:ghost_loc label type_ result)
+ props props_type
+ in
+ let make_type =
+ ptyp_arrow ~loc:ghost_loc (Labelled "check") check_type make_type
+ in
+ let make =
+ value_description ~loc:ghost_loc
+ ~name:{ txt = "make"; loc = ghost_loc }
+ ~type_:make_type ~prim:[ "" ]
+ in
+ let make =
+ {
+ make with
+ pval_attributes = [ attribute ~loc:ghost_loc "mel.obj" (PStr []) ];
+ }
+ in
+ let module_name = gen_symbol ~prefix:"Jsx_props" () in
+ let module_ =
+ pmod_structure ~loc:ghost_loc [ pstr_primitive ~loc:ghost_loc make ]
+ in
+ let call =
+ pexp_apply ~loc
+ (pexp_ident ~loc:ghost_loc
+ { txt = Ldot (Lident module_name, "make"); loc = ghost_loc })
+ ((Labelled "check", check) :: args)
+ in
+ pexp_letmodule ~loc:ghost_loc
+ { txt = Some module_name; loc = ghost_loc }
+ module_ call
diff --git a/ppx/reason_react_ppx.ml b/ppx/reason_react_ppx.ml
index 1f5f4d24e..0167052a9 100644
--- a/ppx/reason_react_ppx.ml
+++ b/ppx/reason_react_ppx.ml
@@ -620,7 +620,10 @@ let jsxMapper =
let component = (nolabel, componentNameExpr)
and props =
( nolabel,
- Binding.ReactDOM.domProps ~applyLoc:parentExpLoc ~loc:callerLoc props )
+ Dom_props.make ~loc:parentExpLoc
+ ~dom_props:
+ (Binding.ReactDOM.domProps ~applyLoc:parentExpLoc ~loc:callerLoc)
+ props )
in
let loc = parentExpLoc in
let gloc = { loc with loc_ghost = true } in
diff --git a/test/ReactDOM__test.re b/test/ReactDOM__test.re
index 7d82ad6eb..fbd6b684c 100644
--- a/test/ReactDOM__test.re
+++ b/test/ReactDOM__test.re
@@ -13,6 +13,56 @@ module Stream = {
};
describe("ReactDOM", () => {
+ describe("data attributes", () => {
+ test("renders arbitrary camelCase names alongside ordinary props", () => {
+ let html =
+ ReactDOMServer.renderToStaticMarkup(
+
+
+
,
+ );
+ expect(html)
+ ->toBe(
+ "
",
+ );
+ });
+
+ test("omits absent optional attributes", () => {
+ let render = dataFoo =>
+ ReactDOMServer.renderToStaticMarkup();
+ expect(render(None))->toBe("");
+ expect(render(Some("value")))
+ ->toBe("");
+ });
+
+ test("preserves ordinary property renaming", () => {
+ let html =
+ ReactDOMServer.renderToStaticMarkup(
+ ,
+ );
+ expect(html)
+ ->toBe(
+ "",
+ );
+ });
+
+ test("evaluates each prop expression once", () => {
+ let evaluations = ref(0);
+ let next = value => {
+ incr(evaluations);
+ value;
+ };
+ let element =
+
+ {next("child")->React.string}
+
;
+ expect(evaluations.contents)->toBe(3);
+ expect(ReactDOMServer.renderToStaticMarkup(element))
+ ->toBe("child
");
+ expect(evaluations.contents)->toBe(3);
+ });
+ });
+
describe("ReactDOM.Server", () => {
test("renderToString", () => {
let string =
diff --git a/test/blackbox-tests/data-attributes.t/input.re.in b/test/blackbox-tests/data-attributes.t/input.re.in
new file mode 100644
index 000000000..075717df9
--- /dev/null
+++ b/test/blackbox-tests/data-attributes.t/input.re.in
@@ -0,0 +1,43 @@
+let first = ;
+let second = ;
+let onlyData = ;
+let ordinaryData = ;
+
+let optional = (~className=?, ~dataFoo=?, ()) => ;
+
+let renamed =
+ ;
+
+let withChildren =
+
+
+
+
;
+
+let withRefAndEvent = (elementRef, handleClick) =>
+ ;
+
+let optionalKey = (~key=?, ()) => ;
+
+module Component = {
+ [@react.component]
+ let make = (~dataFoo) => ;
+};
+
+let component = ;
+
+external next: string => string = "next";
+let effects = ;
+
+let ordinary = ;
diff --git a/test/blackbox-tests/data-attributes.t/run.t b/test/blackbox-tests/data-attributes.t/run.t
new file mode 100644
index 000000000..87c62c5a6
--- /dev/null
+++ b/test/blackbox-tests/data-attributes.t/run.t
@@ -0,0 +1,217 @@
+DOM data attributes use a constructor for each JSX occurrence, with ordinary
+props checked against ReactDOM.domProps and no runtime validation callback.
+
+ $ cat > dune-project < (lang dune 3.8)
+ > (using melange 0.1)
+ > EOF
+
+ $ cat > dune < (melange.emit
+ > (target output)
+ > (alias mel)
+ > (emit_stdlib false)
+ > (libraries reason-react)
+ > (preprocess (pps melange.ppx reason-react-ppx)))
+ > EOF
+
+ $ cp input.re.in input.re
+ $ chmod u+w input.re
+ $ dune build @mel
+
+ $ cat _build/default/output/input.js
+ // Generated by Melange
+ 'use strict';
+
+ const Caml_option = require("melange.js/caml_option.js");
+ const JsxRuntime = require("react/jsx-runtime");
+
+ const first = JsxRuntime.jsx("div", {
+ className: "first",
+ "data-foo": "one"
+ });
+
+ const second = JsxRuntime.jsx("div", {
+ id: "second",
+ "data-bar": "two",
+ "data-test-id": "three"
+ });
+
+ const onlyData = JsxRuntime.jsx("div", {
+ "data-foo": "one"
+ });
+
+ const ordinaryData = JsxRuntime.jsx("object", {
+ data: "file",
+ datatype: "text",
+ "data-test-id": "object"
+ });
+
+ function optional(className, dataFoo, param) {
+ let tmp = {};
+ if (className !== undefined) {
+ tmp.className = Caml_option.valFromOption(className);
+ }
+ if (dataFoo !== undefined) {
+ tmp["data-foo"] = Caml_option.valFromOption(dataFoo);
+ }
+ return JsxRuntime.jsx("div", tmp);
+ }
+
+ const renamed = JsxRuntime.jsx("div", {
+ "data-test-id": "aliases",
+ "aria-label": "label",
+ "aria-activedescendant": "descendant",
+ as: "button",
+ begin: "0",
+ end: "1",
+ in: "source",
+ open: true,
+ to: "target",
+ type: "button"
+ });
+
+ const withChildren = JsxRuntime.jsxs("div", {
+ children: [
+ JsxRuntime.jsx("span", {
+ "data-foo": "child"
+ }),
+ JsxRuntime.jsx("span", {})
+ ],
+ "data-test-id": "parent"
+ }, "parent");
+
+ function withRefAndEvent(elementRef, handleClick) {
+ return JsxRuntime.jsx("button", {
+ ref: elementRef,
+ onClick: handleClick,
+ "data-test-id": "button"
+ });
+ }
+
+ function optionalKey(key, param) {
+ return JsxRuntime.jsx("div", {
+ "data-foo": "keyed"
+ }, key !== undefined ? Caml_option.valFromOption(key) : undefined);
+ }
+
+ function Input$Component(Props) {
+ let dataFoo = Props.dataFoo;
+ return JsxRuntime.jsx("div", {
+ "data-foo": dataFoo
+ });
+ }
+
+ const Component = {
+ make: Input$Component
+ };
+
+ const component = JsxRuntime.jsx(Input$Component, {
+ dataFoo: "component"
+ });
+
+ const effects = JsxRuntime.jsx("div", {
+ className: next("class"),
+ "data-foo": next("data")
+ });
+
+ const ordinary = JsxRuntime.jsx("div", {
+ className: "unchanged"
+ });
+
+ module.exports = {
+ first,
+ second,
+ onlyData,
+ ordinaryData,
+ optional,
+ renamed,
+ withChildren,
+ withRefAndEvent,
+ optionalKey,
+ Component,
+ component,
+ effects,
+ ordinary,
+ }
+ /* first Not a pure module */
+
+Ordinary prop types are still checked.
+
+ $ cat > input.re < let element = ;
+ > EOF
+ $ dune build @mel
+ File "input.re", line 1, characters 29-31:
+ 1 | let element = ;
+ ^^
+ Error: The constant 42 has type int but an expression was expected of type
+ string
+ [1]
+
+Data attribute values must be strings.
+
+ $ cat > input.re < let element = ;
+ > EOF
+ $ dune build @mel
+ File "input.re", line 1, characters 27-29:
+ 1 | let element = ;
+ ^^
+ Error: The constant 42 has type int but an expression was expected of type
+ string
+ [1]
+
+Optional data attribute values are checked too.
+
+ $ cat > input.re < let element = ;
+ > EOF
+ $ dune build @mel
+ File "input.re", line 1, characters 33-35:
+ 1 | let element = ;
+ ^^
+ Error: The constant 42 has type int but an expression was expected of type
+ string
+ [1]
+
+Renamed ordinary props retain their original types.
+
+ $ cat > input.re < let element = ;
+ > EOF
+ $ dune build @mel
+ File "input.re", line 1, characters 25-30:
+ 1 | let element = ;
+ ^^^^^
+ Error: This constant has type string but an expression was expected of type
+ bool
+ [1]
+
+Unknown ordinary props still fail. Only show the final diagnostic, since the
+constructor's list of valid props is long.
+
+ $ cat > input.re < let element = ;
+ > EOF
+ $ dune build @mel 2>&1 | tail -n 2
+ ?suppressHydrationWarning:bool -> ReactDOM.domProps
+ This argument cannot be applied with label ~clasName
+
+Component props do not acquire special data attribute handling.
+
+ $ cat > input.re < module Component = {
+ > [@react.component]
+ > let make = () => React.null;
+ > };
+ > let element = ;
+ > EOF
+ $ dune build @mel
+ File "input.re", line 5, characters 33-36:
+ 5 | let element = ;
+ ^^^
+ Error: The function applied to this argument has type
+ ?key:string -> < > Js.t
+ This argument cannot be applied with label ~dataFoo
+ [1]
diff --git a/test/blackbox-tests/dune b/test/blackbox-tests/dune
index 83224c3c1..8840bbc51 100644
--- a/test/blackbox-tests/dune
+++ b/test/blackbox-tests/dune
@@ -1,4 +1,5 @@
(cram
(package reason-react)
(deps
- (package reason-react)))
+ (package reason-react)
+ (package reason-react-ppx)))
diff --git a/test/dune b/test/dune
index 0dde05c81..be549402e 100644
--- a/test/dune
+++ b/test/dune
@@ -1,6 +1,7 @@
(melange.emit
(alias runtest)
(target test)
+ (package reason-react)
(module_systems
(commonjs bs.js))
(libraries