Create interface file: add support for JSX V4.

Author: cristianoc

analysis/src/CreateInterface.ml

@@ -164,7 +164,7 @@ let printSignature ~extractor ~signature =
 
   let buf = Buffer.create 10 in
 
-  let getComponentType (typ : Types.type_expr) =
+  let getComponentTypeV3 (typ : Types.type_expr) =
     let reactElement =
       Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) []
     in
@@ -183,6 +183,29 @@ let printSignature ~extractor ~signature =
     | _ -> None
   in
 
+  let getComponentTypeV4 (typ : Types.type_expr) =
+    let reactElement =
+      Ctype.newconstr (Pdot (Pident (Ident.create "React"), "element", 0)) []
+    in
+    match typ.desc with
+    | Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _)
+      when Ident.name propsId = "props" ->
+      Some (typeArgs, retType)
+    | Tconstr
+        ( Pdot (Pident {name = "React"}, "component", _),
+          [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}],
+          _ )
+      when Ident.name propsId = "props" ->
+      Some (typeArgs, reactElement)
+    | Tconstr
+        ( Pdot (Pident {name = "React"}, "componentLike", _),
+          [{desc = Tconstr (Path.Pident propsId, typeArgs, _)}; retType],
+          _ )
+      when Ident.name propsId = "props" ->
+      Some (typeArgs, retType)
+    | _ -> None
+  in
+
   let rec processSignature ~indent (signature : Types.signature) : unit =
     match signature with
     | Sig_value
@@ -193,14 +216,14 @@ let printSignature ~extractor ~signature =
       when Ident.name makePropsId = Ident.name makeId ^ "Props"
            && ((* from implementation *) makePropsLoc.loc_ghost
               || (* from interface *) makePropsLoc = makeValueDesc.val_loc)
-           && getComponentType makeValueDesc.val_type <> None ->
+           && getComponentTypeV3 makeValueDesc.val_type <> None ->
       (*
         {"name": string} => retType  ~~>  (~name:string) => retType
         React.component<{"name": string}>  ~~>  (~name:string) => React.element
         React.componentLike<{"name": string}, retType>  ~~>  (~name:string) => retType
       *)
       let tObj, retType =
-        match getComponentType makeValueDesc.val_type with
+        match getComponentTypeV3 makeValueDesc.val_type with
         | None -> assert false
         | Some (tObj, retType) -> (tObj, retType)
       in
@@ -213,6 +236,60 @@ let printSignature ~extractor ~signature =
       Buffer.add_string buf (indent ^ "@react.component\n");
       Buffer.add_string buf (indent ^ newItemStr ^ "\n");
       processSignature ~indent rest
+    | Sig_type
+        ( propsId,
+          {
+            type_params;
+            type_kind = Type_record (labelDecls, Record_optional_labels optLbls);
+          },
+          _ )
+      :: Sig_value (makeId (* make *), makeValueDesc)
+      :: rest
+      when Ident.name propsId = "props"
+           && getComponentTypeV4 makeValueDesc.val_type <> None
+           && optLbls |> List.mem "key" ->
+      (* PPX V4 component declaration:
+         type props = {..., key?: _}
+         let v = ...
+      *)
+      let newItemStr =
+        let typeArgs, retType =
+          match getComponentTypeV4 makeValueDesc.val_type with
+          | Some x -> x
+          | None -> assert false
+        in
+        let rec mkFunType (labelDecls : Types.label_declaration list) =
+          match labelDecls with
+          | [] -> retType
+          | labelDecl :: rest ->
+            let propType =
+              CompletionBackEnd.instantiateType ~typeParams:type_params
+                ~typeArgs labelDecl.ld_type
+            in
+            let lblName = labelDecl.ld_id |> Ident.name in
+            let lbl =
+              if List.mem lblName optLbls then Asttypes.Optional lblName
+              else Labelled lblName
+            in
+            if lblName = "key" then mkFunType rest
+            else
+              {retType with desc = Tarrow (lbl, propType, mkFunType rest, Cok)}
+        in
+        let funType =
+          if List.length labelDecls = 1 (* No props: only "key "*) then
+            let tUnit =
+              Ctype.newconstr (Path.Pident (Ident.create "unit")) []
+            in
+            {retType with desc = Tarrow (Nolabel, tUnit, retType, Cok)}
+          else mkFunType labelDecls
+        in
+        sigItemToString
+          (Printtyp.tree_of_value_description makeId
+             {makeValueDesc with val_type = funType})
+      in
+      Buffer.add_string buf (indent ^ "@react.component\n");
+      Buffer.add_string buf (indent ^ newItemStr ^ "\n");
+      processSignature ~indent rest
     | Sig_module (id, modDecl, recStatus) :: rest ->
       let colonOrEquals =
         match modDecl.md_type with

analysis/vendor/compiler-libs-406/includecore.ml

@@ -306,7 +306,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
         let err = compare_records ~loc env decl1.type_params decl2.type_params
             1 labels1 labels2 in
         if err <> [] || rep1 = rep2 then err else
-        [Record_representation (rep2 = Record_float)]
+        [Record_representation (rep2 = Record_float_unused)]
     | (Type_open, Type_open) -> []
     | (_, _) -> [Kind]
   in

analysis/vendor/compiler-libs-406/typecore.ml

@@ -780,7 +780,7 @@ module Label = NameChoice (struct
   let unbound_name_error = Typetexp.unbound_label_error
   let in_env lbl =
     match lbl.lbl_repres with
-    | Record_regular | Record_float | Record_unboxed false -> true
+    | Record_regular | Record_optional_labels _ | Record_float_unused | Record_unboxed false -> true
     | Record_unboxed true | Record_inlined _ | Record_extension -> false
 end)
 
@@ -2015,9 +2015,9 @@ struct
       | Texp_record { fields = es; extended_expression = eo;
                       representation = rep } ->
           let use = match rep with
-            | Record_float -> Use.inspect
+            | Record_float_unused -> Use.inspect
             | Record_unboxed _ -> (fun x -> x)
-            | Record_regular | Record_inlined _
+            | Record_regular | Record_optional_labels _ | Record_inlined _
             | Record_extension -> Use.guard
           in
           let field env = function

analysis/vendor/compiler-libs-406/typedecl.ml

@@ -495,7 +495,7 @@ let transl_declaration env sdecl id =
           let rep =
             if unbox then Record_unboxed false
             else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
-            then Record_float
+            then Record_float_unused
             else Record_regular
           in
           Ttype_record lbls, Type_record(lbls', rep)

analysis/vendor/compiler-libs-406/types.ml

@@ -159,11 +159,12 @@ and type_kind =
   | Type_open
 
 and record_representation =
-    Record_regular                      (* All fields are boxed / tagged *)
-  | Record_float                        (* All fields are floats *)
-  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
-  | Record_inlined of int               (* Inlined record *)
-  | Record_extension                    (* Inlined record under extension *)
+  | Record_regular                        (* All fields are boxed / tagged *)
+  | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
+  | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int                 (* Inlined record *)
+  | Record_extension                      (* Inlined record under extension *)
+  | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =
   {
@@ -346,4 +347,4 @@ type label_description =
     lbl_private: private_flag;          (* Read-only field? *)
     lbl_loc: Location.t;
     lbl_attributes: Parsetree.attributes;
-   }
+   }

analysis/vendor/compiler-libs-406/types.mli

@@ -305,11 +305,12 @@ and type_kind =
   | Type_open
 
 and record_representation =
-    Record_regular                      (* All fields are boxed / tagged *)
-  | Record_float                        (* All fields are floats *)
-  | Record_unboxed of bool    (* Unboxed single-field record, inlined or not *)
-  | Record_inlined of int               (* Inlined record *)
-  | Record_extension                    (* Inlined record under extension *)
+  | Record_regular                        (* All fields are boxed / tagged *)
+  | Record_float_unused                   (* Was: all fields are floats. Now: unused *)
+  | Record_unboxed of bool                (* Unboxed single-field record, inlined or not *)
+  | Record_inlined of int                 (* Inlined record *)
+  | Record_extension                      (* Inlined record under extension *)
+  | Record_optional_labels of string list (* List of optional labels *)
 
 and label_declaration =
   {