Support data-* attributes in DOM JSX

CHANGES.md

@@ -1,5 +1,6 @@
 # 0.17.0
 
+* Support custom `data-*` attributes in DOM JSX, including optional string values (@anmonteiro in https://github.com/reasonml/reason-react/pull/933)
 * Upgrade `ppxlib` lower bound to `0.36` (@anmonteiro in https://github.com/reasonml/reason-react/pull/883)
 * Remove `fomat` from ReactDOM's props (@davesnx in https://github.com/reasonml/reason-react/pull/929)
 * Fix typo on `onEncrypted` (@davesnx in https://github.com/reasonml/reason-react/pull/930)

README.md

@@ -27,6 +27,21 @@ let make = (~name) => <h1> {React.string("Hello " ++ name)} </h1>
 
 See all of our examples [here](https://reasonml.github.io/reason-react/docs/en/simple). For a full application, check out [reason-react-hacker-news](https://github.com/reasonml-community/reason-react-hacker-news).
 
+DOM elements accept custom data attributes in camelCase:
+
+```reason
+<div className="item" dataTestId="item" dataState="ready" />
+```
+
+This produces `data-test-id` and `data-state` attributes. Values are strings;
+optional attributes such as `<div dataState=?state />` are omitted when `state`
+is `None`. Ordinary props retain their existing type checks. Data props on
+user-defined components keep their declared names and types.
+
+Each uppercase ASCII letter adds a hyphen and becomes lowercase; digits and
+underscores are preserved. For example, `dataVersion2` becomes `data-version2`
+and `dataFoo__bar` becomes `data-foo__bar`.
+
 <!-- ## Getting Started -->
 
 ## Using Your Favorite Javascript Libraries

ppx/dom_props.ml

@@ -0,0 +1,248 @@
+open Ppxlib
+open Ast_builder.Default
+
+let attribute ~loc ?(payload = PStr []) name =
+  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 ignored_type ~loc typ =
+  { typ with ptyp_attributes = [ attribute ~loc "mel.ignore" ] }
+
+(* [mel.obj] requires a literal [unit] type for unlabelled arguments. Use an
+   ignored labelled argument so the type can be qualified against shadowing. *)
+let make_label = function Nolabel -> Labelled "__jsx_unit" | label -> label
+
+type prop = {
+  label : arg_label;
+  variable : string;
+  typ : core_type;
+  data_name : string option;
+  expression : expression;
+}
+
+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 synthetic_loc = Location.none in
+    let stdlib_type name =
+      ptyp_constr ~loc:ghost_loc
+        { txt = Ldot (Ldot (Lident "Stdlib", name), "t"); loc = ghost_loc }
+        []
+    in
+    let unit_type = stdlib_type "Unit" in
+    let string_type = stdlib_type "String" in
+    let props_type =
+      ptyp_constr ~loc:ghost_loc
+        { txt = Ldot (Lident "ReactDOM", "domProps"); loc = ghost_loc }
+        []
+    in
+    let data_names = Hashtbl.create 8 in
+    let props =
+      List.map
+        (fun (label, expression) ->
+          let variable = gen_symbol ~prefix:"prop" () in
+          let data_name = data_attribute (label_name label) in
+          Option.iter
+            (fun name ->
+              if Hashtbl.mem data_names name then
+                Location.raise_errorf ~loc:expression.pexp_loc
+                  "JSX: duplicate data attribute %S" name;
+              Hashtbl.add data_names name ())
+            data_name;
+          let typ =
+            match (label, data_name) with
+            | Nolabel, _ -> unit_type
+            | _, Some _ -> string_type
+            | _, None -> ptyp_var ~loc:synthetic_loc variable
+          in
+          { label; variable; typ; data_name; expression })
+        args
+    in
+    let ordinary_props =
+      List.filter (fun prop -> prop.data_name = None) props
+    in
+    let arrow { label; typ; _ } result =
+      ptyp_arrow ~loc:ghost_loc label typ 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 =
+      ignored_type ~loc:ghost_loc
+        (List.fold_right arrow ordinary_props props_type)
+    in
+    let editor_copy { pexp_desc; _ } =
+      (* Reason represents completion holes and partially typed props as
+         identifiers. Copy only those small expressions: copying arbitrary
+         values would duplicate nested JSX expansions and their typing work. *)
+      match pexp_desc with
+      | Pexp_ident _ -> true
+      | _ -> false
+    in
+    let check_args =
+      List.map
+        (fun { label; variable; expression; _ } ->
+          (label, evar ~loc:expression.pexp_loc variable))
+        ordinary_props
+    in
+    let hidden_check = dom_props check_args in
+    let hidden_check =
+      {
+        hidden_check with
+        pexp_attributes = [ attribute ~loc:ghost_loc "merlin.hide" ];
+      }
+    in
+    let editor_args =
+      List.map
+        (fun { label; variable; expression; _ } ->
+          let expr =
+            if editor_copy expression then
+              {
+                expression with
+                pexp_attributes =
+                  attribute ~loc:expression.pexp_loc "merlin.focus"
+                  :: expression.pexp_attributes;
+              }
+            else
+              let expr = evar ~loc:expression.pexp_loc variable in
+              {
+                expr with
+                pexp_attributes = [ attribute ~loc:synthetic_loc "merlin.hide" ];
+              }
+          in
+          (label, expr))
+        ordinary_props
+    in
+    let check_body =
+      (* Infer the constructor's argument types first, then give Merlin a DOM
+         application containing the original identifiers. Other values remain
+         visible in the constructor, with the inferred types as their context. *)
+      pexp_let ~loc:ghost_loc Nonrecursive
+        [
+          value_binding ~loc:synthetic_loc
+            ~pat:(ppat_any ~loc:synthetic_loc)
+            ~expr:hidden_check;
+        ]
+        (dom_props editor_args)
+    in
+    let check =
+      List.fold_right
+        (fun { label; variable; _ } body ->
+          pexp_fun ~loc:ghost_loc label None
+            (pvar ~loc:synthetic_loc variable)
+            body)
+        ordinary_props check_body
+    in
+    let make_type =
+      List.fold_right
+        (fun { label; typ; data_name; _ } result ->
+          let name =
+            match data_name with
+            (* Melange strips the last [__suffix], even in [mel.as]. An empty
+               suffix preserves any double underscores in the attribute. *)
+            | Some name -> Some (name ^ "__")
+            | None -> js_name (label_name label)
+          in
+          let attributes =
+            match (label, name) with
+            | Nolabel, _ -> [ attribute ~loc:ghost_loc "mel.ignore" ]
+            | _, None -> []
+            | _, Some name ->
+                [
+                  attribute ~loc:ghost_loc "mel.as"
+                    ~payload:
+                      (PStr
+                         [
+                           pstr_eval ~loc:ghost_loc
+                             (estring ~loc:ghost_loc name)
+                             [];
+                         ]);
+                ]
+          in
+          ptyp_arrow ~loc:ghost_loc (make_label label)
+            { typ with ptyp_attributes = attributes }
+            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" ] }
+    in
+    let module_name = gen_symbol ~prefix:"Jsx_props" () in
+    let module_ =
+      pmod_structure ~loc:synthetic_loc
+        [ pstr_primitive ~loc:synthetic_loc make ]
+    in
+    let call =
+      pexp_apply ~loc
+        (pexp_ident ~loc:synthetic_loc
+           { txt = Ldot (Lident module_name, "make"); loc = synthetic_loc })
+        ((Labelled "check", check)
+        :: List.map
+             (fun (label, expression) ->
+               let expression =
+                 if
+                   Option.is_none (data_attribute (label_name label))
+                   && (editor_copy expression
+                      || (label = Nolabel && expression.pexp_loc.loc_ghost))
+                 then
+                   {
+                     expression with
+                     pexp_attributes =
+                       attribute ~loc:expression.pexp_loc "merlin.hide"
+                       :: expression.pexp_attributes;
+                   }
+                 else expression
+               in
+               (make_label label, expression))
+             args)
+    in
+    pexp_letmodule ~loc:ghost_loc
+      { txt = Some module_name; loc = ghost_loc }
+      module_ call

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