add parsing & jsx mapper for spread props

with the general type checking the structural typings `@obj`

Author: mununki

cli/reactjs_jsx_ppx_v3.ml

@@ -191,31 +191,108 @@ let rec recursivelyMakeNamedArgsForExternal list args =
   | [] -> args
   [@@raises Invalid_argument]
 
-(* Build an AST node for the [@bs.obj] representing props for a component *)
-let makePropsValue fnName loc namedArgListWithKeyAndRef propsType =
-  let propsName = fnName ^ "Props" in
-  {
-    pval_name = { txt = propsName; loc };
-    pval_type =
-      recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef
-        (Typ.arrow nolabel
-           { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = [] }
-           propsType);
-    pval_prim = [ "" ];
-    pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ];
-    pval_loc = loc;
-  }
-  [@@raises Invalid_argument]
-
-(* Build an AST node representing an `external` with the definition of the [@bs.obj] *)
-let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType =
-  { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) }
-  [@@raises Invalid_argument]
-
-(* Build an AST node for the signature of the `external` definition *)
-let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType =
-  { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) }
-  [@@raises Invalid_argument]
+(* List.filter_map in 4.08.0 *)
+let filterMap f =
+  let rec aux accu = function
+    | [] -> List.rev accu
+    | x :: l -> (
+        match f x with None -> aux accu l | Some v -> aux (v :: accu) l )
+  in
+  aux []
+
+  (* make record from props and spread props if exists *)
+  let recordFromProps { pexp_loc } callArguments =
+    let rec removeLastPositionUnitAux props acc =
+      match props with
+      | [] -> acc
+      | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc
+      | (Nolabel, _) :: _rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position")
+      | prop :: rest -> removeLastPositionUnitAux rest (prop :: acc)
+    in
+    let props, propsToSpread = removeLastPositionUnitAux callArguments []
+                                |> List.rev
+                                |> List.partition (fun (label, _) -> label <> labelled "spreadProps") in
+    let fields = props |> List.map (fun (arg_label, ({ pexp_loc } as expr) ) ->
+      ({ txt = (Longident.parse (getLabel arg_label)); loc = pexp_loc} , expr))
+    in
+    let spreadFields = propsToSpread |> List.map (fun (_, expression) -> expression) in
+    match spreadFields with
+    | [] -> { pexp_desc=Pexp_record (fields, None); pexp_loc; pexp_attributes=[]}
+    | [ spreadProps] -> { pexp_desc=Pexp_record (fields, Some spreadProps); pexp_loc; pexp_attributes=[] }
+    | spreadProps :: _ -> { pexp_desc=Pexp_record (fields, Some spreadProps); pexp_loc; pexp_attributes=[] }
+  
+(* @obj type props = { id: option<string>, key: ... } *)
+let makePropsRecordType fnName loc namedTypeList =
+  let labelDeclList =
+    namedTypeList
+    |> List.map (fun (label, _, interiorType) ->
+           Type.field ~loc { txt = label; loc } interiorType)
+  in
+  (* 'id, 'className, ... *)
+  let params =
+    namedTypeList
+    |> filterMap (fun (_, _, interiorType) ->
+           match interiorType with
+           | { ptyp_desc = Ptyp_var _ } as param -> Some (param, Invariant)
+           | _ -> None)
+  in
+  Str.type_ Nonrecursive
+    [
+      Type.mk ~loc
+        ~attrs:[ ({ txt = "bs.obj"; loc }, PStr []) ]
+        ~params
+        { txt = fnName ^ "Props"; loc }
+        ~kind:(Ptype_record labelDeclList);
+    ]
+
+(* let makeProps = (props: makeProps) => props *)
+let makePropsFn fnName loc =
+  Str.value Nonrecursive
+    [
+      Vb.mk
+        (Pat.var { txt = fnName ^ "Props"; loc })
+        (Exp.fun_ Nolabel None
+           (Pat.constraint_
+              (Pat.var { txt = "props"; loc })
+              (Typ.constr ~loc
+                 { txt = Longident.parse @@ fnName ^ "Props"; loc }
+                 []))
+           (Exp.ident { txt = Longident.parse "props"; loc }));
+    ]
+
+(* @obj type props = { id: option<string>, key: ... } *)
+let makePropsRecordTypeSig fnName loc namedTypeList =
+  let labelDeclList =
+    namedTypeList
+    |> List.map (fun (label, _, interiorType) ->
+           Type.field ~loc { txt = label; loc } interiorType)
+  in
+  let params =
+    namedTypeList
+    |> filterMap (fun (_, _, interiorType) ->
+           match interiorType with
+           | { ptyp_desc = Ptyp_var _ } as param -> Some (param, Invariant)
+           | _ -> None)
+  in
+  Sig.type_ Nonrecursive
+    [
+      Type.mk ~loc
+        ~attrs:[ ({ txt = "bs.obj"; loc }, PStr []) ]
+        ~params
+        { txt = fnName ^ "Props"; loc }
+        ~kind:(Ptype_record labelDeclList);
+    ]
+
+(* let makeProps: makeProps => props *)
+let makePropsFnSig fnName loc =
+  Sig.value ~loc
+    (Val.mk
+       { txt = fnName ^ "Props"; loc }
+       (Typ.arrow Nolabel
+          (Typ.constr
+             (Location.mkloc (Longident.parse (fnName ^ "Props")) loc)
+             [])
+          (Typ.constr (Location.mkloc (Longident.parse @@ fnName ^ "Props") loc) [])))
 
 (* Build an AST node for the props name when converted to an object inside the function signature  *)
 let makePropsName ~loc name = { ppat_desc = Ppat_var { txt = name; loc }; ppat_loc = loc; ppat_attributes = [] }
@@ -226,13 +303,6 @@ let makeObjectField loc (str, attrs, type_) = Otag ({ loc; txt = str }, attrs, t
 let makePropsType ~loc namedTypeList =
   Typ.mk ~loc (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed))
 
-(* Builds an AST node for the entire `external` definition of props *)
-let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList =
-  makePropsExternal fnName loc
-    (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef)
-    (makePropsType ~loc namedTypeList)
-  [@@raises Invalid_argument]
-
 let newtypeToVar newtype type_ =
   let var_desc = Ptyp_var ("type-" ^ newtype) in
   let typ (mapper : Ast_mapper.mapper) typ =
@@ -248,7 +318,7 @@ let newtypeToVar newtype type_ =
 let jsxMapper () =
   let jsxVersion = ref None in
 
-  let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments =
+  let transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments =
     let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in
     let argsForMake = argsWithLabels in
     let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in
@@ -265,8 +335,8 @@ let jsxMapper () =
             (* this is a hack to support react components that introspect into their children *)
             childrenArg := Some expression;
             [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] )
-      @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ]
     in
+    let record = recordFromProps callExpression args in
     let isCap str =
       let first = String.sub str 0 1 [@@raises Invalid_argument] in
       let capped = String.uppercase_ascii first in
@@ -285,7 +355,7 @@ let jsxMapper () =
       | Ldot (ident, path) -> Ldot (ident, path ^ "Props")
       | _ -> raise (Invalid_argument "JSX name can't be the result of function applications")
     in
-    let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in
+    let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) [ (nolabel, record) ] in
     (* handle key, ref, children *)
     (* React.createElement(Component.make, props, ...children) *)
     match !childrenArg with
@@ -300,8 +370,9 @@ let jsxMapper () =
     [@@raises Invalid_argument]
   in
 
-  let transformLowercaseCall3 mapper loc attrs callArguments id =
+  let transformLowercaseCall3 mapper loc attrs callExpression callArguments id =
     let children, nonChildrenProps = extractChildren ~loc callArguments in
+    let record = recordFromProps callExpression nonChildrenProps in
     let componentNameExpr = constantString ~loc id in
     let childrenExpr = transformChildrenIfList ~loc ~mapper children in
     let createElementCall =
@@ -324,17 +395,12 @@ let jsxMapper () =
       match nonChildrenProps with
       | [ _justTheUnitArgumentAtEnd ] ->
           [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ]
-      | nonEmptyProps ->
-          let propsCall =
-            Exp.apply ~loc
-              (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") })
-              (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)))
-          in
+      | _nonEmptyProps ->
           [
             (* "div" *)
             (nolabel, componentNameExpr);
-            (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *)
-            (labelled "props", propsCall);
+            (* ReactDOMRe.props({className=blabla, foo=bar}) *)
+            (labelled "props", record);
             (* [|moreCreateElementCallsHere|] *)
             (nolabel, childrenExpr);
           ]
@@ -469,12 +535,15 @@ let jsxMapper () =
             in
             let innerType, propTypes = getPropTypes [] pval_type in
             let namedTypeList = List.fold_left argToConcreteType [] propTypes in
-            let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in
-            let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in
-            let externalPropsDecl =
-              makePropsExternal fnName pstr_loc
-                ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes)
-                retPropsType
+            let retPropsType = (Typ.constr ~loc:pstr_loc (Location.mkloc (Longident.parse (fnName ^ "Props")) pstr_loc) []) in
+            (* @obj type makeProps = { ... } *)
+            let propsRecordType =
+              makePropsRecordType fnName pstr_loc
+                (("key", [], keyType pstr_loc) :: namedTypeList)
+            in
+            (* let makeProps = (props: makeProps) => props *)
+            let propsFn =
+              makePropsFn fnName pstr_loc
             in
             (* can't be an arrow because it will defensively uncurry *)
             let newExternalType =
@@ -492,7 +561,7 @@ let jsxMapper () =
                     };
               }
             in
-            externalPropsDecl :: newStructure :: returnStructures
+            propsRecordType :: propsFn :: newStructure :: returnStructures
         | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") )
     (* let component = ... *)
     | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } ->
@@ -616,17 +685,6 @@ let jsxMapper () =
             let namedArgList, newtypes, forwardRef =
               recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] []
             in
-            let namedArgListWithKeyAndRef =
-              (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc))
-              :: namedArgList
-            in
-            let namedArgListWithKeyAndRef =
-              match forwardRef with
-              | Some _ ->
-                  (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None)
-                  :: namedArgListWithKeyAndRef
-              | None -> namedArgListWithKeyAndRef
-            in
             let namedArgListWithKeyAndRefForNew =
               match forwardRef with
               | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ]
@@ -649,25 +707,22 @@ let jsxMapper () =
             in
             let namedTypeList = List.fold_left argToType [] namedArgList in
             let loc = emptyLoc in
-            let externalArgs = (* translate newtypes to type variables *)
-              List.fold_left
-                (fun args newtype ->
-                   List.map (fun (a, b, c, d, e, maybeTyp) ->
-                       match maybeTyp with
-                       | Some typ -> (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
-                       | None -> (a, b, c, d, e, None))
-                     args)
-                namedArgListWithKeyAndRef
-                newtypes
-            in
             let externalTypes = (* translate newtypes to type variables *)
               List.fold_left
                 (fun args newtype ->
                    List.map (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) args)
                 namedTypeList
                 newtypes
             in
-            let externalDecl = makeExternalDecl fnName loc externalArgs externalTypes in
+            (* @obj type makeProps = { ... } *)
+            let propsRecordType =
+              makePropsRecordType fnName pstr_loc
+                (("key", [], keyType pstr_loc) :: namedTypeList)
+            in
+            (* let makeProps = (props: makeProps) => props *)
+            let propsFn =
+              makePropsFn fnName pstr_loc
+            in
             let innerExpressionArgs =
               List.map pluckArg namedArgListWithKeyAndRefForNew
               @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else []
@@ -727,20 +782,22 @@ let jsxMapper () =
               | Nonrecursive ->
                   ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression))
             in
-            (Some externalDecl, bindings, newBinding)
-          else (None, [ binding ], None)
+            (Some propsRecordType, Some propsFn, bindings, newBinding)
+          else (None, None, [ binding ], None)
           [@@raises Invalid_argument]
         in
         let structuresAndBinding = List.map mapBinding valueBindings in
-        let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) =
-          let externs = match extern with Some extern -> extern :: externs | None -> externs in
+        let otherStructures (type_, propsFn, binding, newBinding) (types, propsFns, bindings, newBindings) =
+          let types = match type_ with Some type_ -> type_ :: types | None -> types in
+          let propsFns = match propsFn with Some propsFn -> propsFn :: propsFns | None -> propsFns in
           let newBindings =
             match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings
           in
-          (externs, binding @ bindings, newBindings)
+          (types, propsFns, binding @ bindings, newBindings)
         in
-        let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in
-        externs
+        let types, propsFns, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], [], []) in
+        types
+        @ propsFns
         @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ]
         @ ( match newBindings with
           | [] -> []
@@ -774,12 +831,13 @@ let jsxMapper () =
             in
             let innerType, propTypes = getPropTypes [] pval_type in
             let namedTypeList = List.fold_left argToConcreteType [] propTypes in
-            let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in
-            let retPropsType = makePropsType ~loc:psig_loc namedTypeList in
-            let externalPropsDecl =
-              makePropsExternalSig fnName psig_loc
-                ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes)
-                retPropsType
+            let retPropsType = (Typ.constr (Location.mkloc (Longident.parse (fnName ^ "Props")) psig_loc) []) in
+            let propsRecordType =
+              makePropsRecordTypeSig fnName psig_loc
+                (("key", [], keyType psig_loc) :: namedTypeList)
+            in
+            let propsFnSig =
+              makePropsFnSig fnName psig_loc
             in
             (* can't be an arrow because it will defensively uncurry *)
             let newExternalType =
@@ -797,7 +855,7 @@ let jsxMapper () =
                     };
               }
             in
-            externalPropsDecl :: newStructure :: returnSignatures
+            propsRecordType :: propsFnSig :: newStructure :: returnSignatures
         | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") )
     | signature -> signature :: returnSignatures
     [@@raises Invalid_argument]
@@ -824,7 +882,7 @@ let jsxMapper () =
            ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *)
         | { loc; txt = Lident id } -> (
             match !jsxVersion with
-            | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id
+            | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callExpression callArguments id
             | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") )
         | { txt = Ldot (_, anythingNotCreateElementOrMake) } ->
             raise

cli/reactjs_jsx_ppx_v3.mli

@@ -22,14 +22,14 @@
   transform `[@JSX] [foo]` into
   `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
   v3:
-  transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into
-  `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`.
+  transform `[@JSX] div(~props1=a, ~props2=b, ~spreadProps=props3 ~children=[foo, bar], ())` into
+  `ReactDOMRe.createDOMElementVariadic("div", ~props=({...props3, props1: a, props2: b}), [|foo, bar|])`.
   transform the upper-cased case
-  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into
-  `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))`
+  `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~spreadProps=baz ~children=[], ())` into
+  `React.createElement(Foo.make, Foo.makeProps({...baz, key: a, ref: b, foo: bar}))`
   transform the upper-cased case
-  `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into
-  `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])`
+  `[@JSX] Foo.createElement(~foo=bar, ~spreadProps=baz, ~children=[foo, bar], ())` into
+  `React.createElementVariadic(Foo.make, Foo.makeProps({...baz, foo: bar, children: React.null}), [|foo, bar|])`
   transform `[@JSX] [foo]` into
   `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])`
 *)