ppx: add test for inference regression in keys

.ocamlformat

@@ -1 +1 @@
-version = 0.24.0
+version = 0.26.0

dune-project

@@ -41,6 +41,10 @@
   (reason
    (>= 3.6.0))
   (ocaml-lsp-server :with-test)
+  (merlin
+   (and
+    (= 4.10-414)
+    :with-test))
   (opam-check-npm-deps
    (and
     (= 1.0.0)

ppx/reason_react_ppx.ml

@@ -71,9 +71,9 @@ module Binding = struct
            { loc; txt = Ldot (Lident "ReactDOM", "createElement") })
         [ (nolabel, element); (nolabel, children) ]
 
-    let domProps ~parentExpLoc ~loc props =
-      Builder.pexp_apply ~loc:parentExpLoc
-        (Builder.pexp_ident ~loc:parentExpLoc ~attrs:merlinHideAttrs
+    let domProps ~applyLoc ~loc props =
+      Builder.pexp_apply ~loc:applyLoc
+        (Builder.pexp_ident ~loc:applyLoc ~attrs:merlinHideAttrs
            { loc; txt = Ldot (Lident "ReactDOM", "domProps") })
         props
   end
@@ -507,8 +507,8 @@ let jsxMapper =
     Builder.pexp_construct ~loc:Location.none
       { txt = Lident "()"; loc = Location.none }
       None
-  in
-  let transformUppercaseCall3 ~caller modulePath ~ctxt mapper loc attrs _
+  and key_var_txt = "Key" in
+  let transformUppercaseCall3 ~caller ~ctxt modulePath mapper parentExpLoc attrs
       callArguments =
     let children, argsWithLabels = extractChildren callArguments in
     let argsForMake = argsWithLabels in
@@ -518,7 +518,7 @@ let jsxMapper =
         argsForMake
     in
     let jsxExpr, key, childrenProp =
-      reactJsxExprAndChildren ~loc ~ctxt mapper ~keyProps children
+      reactJsxExprAndChildren ~loc:parentExpLoc ~ctxt ~keyProps mapper children
     in
     let propsArg =
       (match childrenProp with
@@ -549,61 +549,94 @@ let jsxMapper =
             (Invalid_argument
                "JSX name can't be the result of function applications")
     in
-    let props =
-      Builder.pexp_apply ~loc
-        (Builder.pexp_ident ~loc { loc; txt = propsIdent })
-        propsArg
-    in
-    let key_args =
-      match key with
-      | Some (label, key) ->
-          [ (label, mapper#expression ctxt key); (nolabel, unit) ]
-      | None -> []
+    let component =
+      ( nolabel,
+        Builder.pexp_ident ~loc:parentExpLoc { txt = ident; loc = parentExpLoc }
+      )
+    and props =
+      ( nolabel,
+        Builder.pexp_apply ~loc:parentExpLoc
+          (Builder.pexp_ident ~loc:parentExpLoc
+             { loc = parentExpLoc; txt = propsIdent })
+          propsArg )
     in
-    Builder.pexp_apply ~loc ~attrs jsxExpr
-      ([
-         (nolabel, Builder.pexp_ident ~loc { txt = ident; loc });
-         (nolabel, props);
-       ]
-      @ key_args)
+    match key with
+    | None ->
+        Builder.pexp_apply ~loc:parentExpLoc ~attrs jsxExpr [ component; props ]
+    | Some (label, key) ->
+        (* We create a let binding with the value of the key to ensure
+           the inferred type https://github.com/reasonml/reason-react/pull/752 *)
+        let loc = parentExpLoc in
+        Builder.pexp_let ~loc Nonrecursive
+          [
+            {
+              pvb_pat = Builder.ppat_var ~loc { txt = key_var_txt; loc };
+              pvb_expr = mapper#expression ctxt key;
+              pvb_attributes = [];
+              pvb_loc = loc;
+            };
+          ]
+          (Builder.pexp_apply ~loc:parentExpLoc ~attrs jsxExpr
+             [
+               ( label,
+                 Builder.pexp_ident ~loc:parentExpLoc
+                   { txt = Lident key_var_txt; loc = parentExpLoc } );
+               component;
+               props;
+               (nolabel, unit);
+             ])
   in
 
-  let transformLowercaseCall3 ~ctxt parentExpLoc mapper loc attrs callArguments
-      id =
+  let transformLowercaseCall3 ~ctxt parentExpLoc mapper callerLoc attrs
+      callArguments id =
     let children, nonChildrenProps = extractChildren callArguments in
-    let componentNameExpr = constantString ~loc id in
+    let componentNameExpr = constantString ~loc:callerLoc id in
     let keyProps, nonChildrenProps =
       List.partition
         (fun (arg_label, _) -> "key" = getLabel arg_label)
         nonChildrenProps
     in
-    let jsxExpr, args =
-      let jsxExpr, key, childrenProp =
-        reactDomJsxExprAndChildren ~loc:parentExpLoc ~ctxt mapper ~keyProps
-          children
-      in
-      let props =
-        (match childrenProp with
-        | Some childrenProp ->
-            (labelled "children", childrenProp) :: nonChildrenProps
-        | None -> nonChildrenProps)
-        |> List.map (fun (label, expression) ->
-               (label, mapper#expression ctxt expression))
-      in
-      let key_args =
-        match key with
-        | Some (label, key) ->
-            [ (label, mapper#expression ctxt key); (nolabel, unit) ]
-        | None -> []
-      in
-      ( jsxExpr,
-        [
-          (nolabel, componentNameExpr);
-          (nolabel, Binding.ReactDOM.domProps ~parentExpLoc ~loc props);
-        ]
-        @ key_args )
+
+    let jsxExpr, key, childrenProp =
+      reactDomJsxExprAndChildren ~loc:parentExpLoc ~ctxt mapper ~keyProps
+        children
+    in
+    let props =
+      (match childrenProp with
+      | Some childrenProp ->
+          (labelled "children", childrenProp) :: nonChildrenProps
+      | None -> nonChildrenProps)
+      |> List.map (fun (label, expression) ->
+             (label, mapper#expression ctxt expression))
+    in
+    let component = (nolabel, componentNameExpr)
+    and props =
+      ( nolabel,
+        Binding.ReactDOM.domProps ~applyLoc:parentExpLoc ~loc:callerLoc props )
     in
-    Builder.pexp_apply ~loc:parentExpLoc ~attrs jsxExpr args
+    let loc = parentExpLoc in
+    let gloc = { loc with loc_ghost = true } in
+    match key with
+    | Some (label, key) ->
+        (* We create a let binding with the value of the key to ensure
+           the inferred type https://github.com/reasonml/reason-react/pull/752 *)
+        Builder.pexp_let ~loc:gloc Nonrecursive
+          [
+            {
+              pvb_pat = Builder.ppat_var ~loc { txt = key_var_txt; loc };
+              pvb_expr = mapper#expression ctxt key;
+              pvb_attributes = [];
+              pvb_loc = loc;
+            };
+          ]
+          (Builder.pexp_apply ~loc ~attrs jsxExpr
+             [
+               (label, Builder.pexp_ident ~loc { txt = Lident key_var_txt; loc });
+               component;
+               props;
+               (nolabel, unit);
+             ])
+    | None -> Builder.pexp_apply ~loc ~attrs jsxExpr [ component; props ]
   in
 
   let rec recursivelyTransformNamedArgsForMake ~ctxt mapper expr list =
@@ -1296,7 +1329,7 @@ let jsxMapper =
         (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *)
         | { txt = Ldot (modulePath, ("createElement" | "make")) } ->
             transformUppercaseCall3 ~ctxt ~caller:"make" modulePath mapper
-              parentExpLoc attrs callExpression callArguments
+              parentExpLoc attrs callArguments
         (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *)
         (* turn that into
            ReactDOM.createElement("div", ~props=ReactDOM.domProps(~props1=foo,
@@ -1309,7 +1342,7 @@ let jsxMapper =
            https://github.com/reasonml/reason/pull/2541 *)
         | { txt = Ldot (modulePath, anythingNotCreateElementOrMake) } ->
             transformUppercaseCall3 ~ctxt ~caller:anythingNotCreateElementOrMake
-              modulePath mapper parentExpLoc attrs callExpression callArguments
+              modulePath mapper parentExpLoc attrs callArguments
         | { txt = Lapply _ } ->
             (* don't think there's ever a case where this is reached *)
             raise

ppx/test/keys.t/run.t

@@ -32,7 +32,7 @@ _^
       "line": 10,
       "col": 85
     },
-    "type": "ReactDOM.domProps",
+    "type": "string",
     "tail": "no"
   }
 

ppx/test/lower.t/run.t

@@ -95,7 +95,9 @@
                             ~children=
                               examples
                               |> List.map(e =>
+                                   let Key = e.path;
                                    ReactDOM.jsxKeyed(
+                                     ~key=Key,
                                      "li",
                                      ([@merlin.hide] ReactDOM.domProps)(
                                        ~children=
@@ -116,9 +118,8 @@
                                          ),
                                        (),
                                      ),
-                                     ~key=e.path,
                                      (),
-                                   )
+                                   );
                                  )
                               |> React.list,
                             (),