@@ -46,7 +46,33 @@ let ref_type loc =
46
46
{loc; txt = Ldot (Ldot (Lident " Js" , " Nullable" ), " t" )}
47
47
[ref_type_var loc]
48
48
49
- let merlin_focus = ({loc = Location. none; txt = " merlin.focus" }, PStr [] )
49
+ let jsx_element_type ~loc =
50
+ Typ. constr ~loc {loc; txt = Ldot (Lident " Jsx" , " element" )} []
51
+
52
+ let jsx_element_constraint expr =
53
+ Exp. constraint_ expr (jsx_element_type ~loc: expr.pexp_loc)
54
+
55
+ (* Traverse the component body and force every reachable return expression to
56
+ be annotated as `Jsx.element`. This walks through the wrapper constructs the
57
+ PPX introduces (fun/newtype/let/sequence) so that the constraint ends up on
58
+ the real return position even after we rewrite the function. *)
59
+ let rec constrain_jsx_return expr =
60
+ match expr.pexp_desc with
61
+ | Pexp_fun ({rhs} as desc ) ->
62
+ {expr with pexp_desc = Pexp_fun {desc with rhs = constrain_jsx_return rhs}}
63
+ | Pexp_newtype (param , inner ) ->
64
+ {expr with pexp_desc = Pexp_newtype (param, constrain_jsx_return inner)}
65
+ | Pexp_constraint (inner , _ ) ->
66
+ let constrained_inner = constrain_jsx_return inner in
67
+ jsx_element_constraint constrained_inner
68
+ | Pexp_let (rec_flag , bindings , body ) ->
69
+ {
70
+ expr with
71
+ pexp_desc = Pexp_let (rec_flag, bindings, constrain_jsx_return body);
72
+ }
73
+ | Pexp_sequence (first , second ) ->
74
+ {expr with pexp_desc = Pexp_sequence (first, constrain_jsx_return second)}
75
+ | _ -> jsx_element_constraint expr
50
76
51
77
(* Helper method to filter out any attribute that isn't [@react.component] *)
52
78
let other_attrs_pure (loc , _ ) =
@@ -73,7 +99,7 @@ let make_new_binding binding expression new_name =
73
99
pvb_pat =
74
100
{pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = new_name}};
75
101
pvb_expr = expression;
76
- pvb_attributes = [merlin_focus ];
102
+ pvb_attributes = [] ;
77
103
}
78
104
| {pvb_loc} ->
79
105
Jsx_common. raise_error ~loc: pvb_loc
@@ -713,6 +739,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding =
713
739
vb_match_expr named_arg_list expression
714
740
else expression
715
741
in
742
+ let expression = constrain_jsx_return expression in
716
743
(* (ref) => expr *)
717
744
let expression =
718
745
List. fold_left
@@ -839,21 +866,26 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding =
839
866
| _ -> Pat. var {txt = " props" ; loc}
840
867
in
841
868
869
+ let applied_expression =
870
+ Exp. apply
871
+ (Exp. ident
872
+ {
873
+ txt =
874
+ Lident
875
+ (match rec_flag with
876
+ | Recursive -> internal_fn_name
877
+ | Nonrecursive -> fn_name);
878
+ loc;
879
+ })
880
+ [(Nolabel , Exp. ident {txt = Lident " props" ; loc})]
881
+ in
882
+ let applied_expression =
883
+ Jsx_common. async_component ~async: is_async applied_expression
884
+ in
885
+ let applied_expression = constrain_jsx_return applied_expression in
842
886
let wrapper_expr =
843
887
Exp. fun_ ~arity: None Nolabel None props_pattern
844
- ~attrs: binding.pvb_expr.pexp_attributes
845
- (Jsx_common. async_component ~async: is_async
846
- (Exp. apply
847
- (Exp. ident
848
- {
849
- txt =
850
- Lident
851
- (match rec_flag with
852
- | Recursive -> internal_fn_name
853
- | Nonrecursive -> fn_name);
854
- loc;
855
- })
856
- [(Nolabel , Exp. ident {txt = Lident " props" ; loc})]))
888
+ ~attrs: binding.pvb_expr.pexp_attributes applied_expression
857
889
in
858
890
859
891
let wrapper_expr = Ast_uncurried. uncurried_fun ~arity: 1 wrapper_expr in
@@ -876,20 +908,33 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding =
876
908
Some
877
909
(make_new_binding ~loc: empty_loc ~full_module_name modified_binding)
878
910
in
911
+ let binding_expr =
912
+ {
913
+ binding.pvb_expr with
914
+ (* moved to wrapper_expr *)
915
+ pexp_attributes = [] ;
916
+ }
917
+ in
879
918
( None ,
880
919
{
881
920
binding with
882
921
pvb_attributes = binding.pvb_attributes |> List. filter other_attrs_pure;
883
- pvb_expr =
884
- {
885
- binding.pvb_expr with
886
- (* moved to wrapper_expr *)
887
- pexp_attributes = [] ;
888
- };
922
+ pvb_expr = binding_expr |> constrain_jsx_return;
889
923
},
890
924
new_binding )
891
925
else (None , binding, None )
892
926
927
+ let rec collect_prop_types types {ptyp_loc; ptyp_desc} =
928
+ match ptyp_desc with
929
+ | Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as rest}
930
+ when is_labelled arg.lbl || is_optional arg.lbl ->
931
+ collect_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) rest
932
+ | Ptyp_arrow {arg = {lbl = Nolabel } ; ret} -> collect_prop_types types ret
933
+ | Ptyp_arrow {arg; ret = return_value}
934
+ when is_labelled arg.lbl || is_optional arg.lbl ->
935
+ (arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types
936
+ | _ -> types
937
+
893
938
let transform_structure_item ~config item =
894
939
match item with
895
940
(* external *)
@@ -922,19 +967,7 @@ let transform_structure_item ~config item =
922
967
|> Option. map Jsx_common. typ_vars_of_core_type
923
968
|> Option. value ~default: []
924
969
in
925
- let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type ) =
926
- match ptyp_desc with
927
- | Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as typ2}
928
- when is_labelled arg.lbl || is_optional arg.lbl ->
929
- get_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) typ2
930
- | Ptyp_arrow {arg = {lbl = Nolabel } ; ret} -> get_prop_types types ret
931
- | Ptyp_arrow {arg; ret = return_value}
932
- when is_labelled arg.lbl || is_optional arg.lbl ->
933
- ( return_value,
934
- (arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types )
935
- | _ -> (full_type, types)
936
- in
937
- let inner_type, prop_types = get_prop_types [] pval_type in
970
+ let prop_types = collect_prop_types [] pval_type in
938
971
let named_type_list = List. fold_left arg_to_concrete_type [] prop_types in
939
972
let ret_props_type =
940
973
Typ. constr ~loc: pstr_loc
@@ -955,7 +988,7 @@ let transform_structure_item ~config item =
955
988
let new_external_type =
956
989
Ptyp_constr
957
990
( {loc = pstr_loc; txt = module_access_name config " componentLike" },
958
- [ret_props_type; inner_type ] )
991
+ [ret_props_type; jsx_element_type ~loc: pstr_loc ] )
959
992
in
960
993
let new_structure =
961
994
{
@@ -1023,30 +1056,7 @@ let transform_signature_item ~config item =
1023
1056
|> Option. map Jsx_common. typ_vars_of_core_type
1024
1057
|> Option. value ~default: []
1025
1058
in
1026
- let rec get_prop_types types ({ptyp_loc; ptyp_desc} as full_type ) =
1027
- match ptyp_desc with
1028
- | Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as rest}
1029
- when is_optional arg.lbl || is_labelled arg.lbl ->
1030
- get_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) rest
1031
- | Ptyp_arrow
1032
- {
1033
- arg =
1034
- {
1035
- lbl = Nolabel ;
1036
- typ = {ptyp_desc = Ptyp_constr ({txt = Lident " unit" }, _)};
1037
- };
1038
- ret = rest;
1039
- } ->
1040
- get_prop_types types rest
1041
- | Ptyp_arrow {arg = {lbl = Nolabel } ; ret = rest } ->
1042
- get_prop_types types rest
1043
- | Ptyp_arrow {arg; ret = return_value}
1044
- when is_optional arg.lbl || is_labelled arg.lbl ->
1045
- ( return_value,
1046
- (arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types )
1047
- | _ -> (full_type, types)
1048
- in
1049
- let inner_type, prop_types = get_prop_types [] pval_type in
1059
+ let prop_types = collect_prop_types [] pval_type in
1050
1060
let named_type_list = List. fold_left arg_to_concrete_type [] prop_types in
1051
1061
let ret_props_type =
1052
1062
Typ. constr
@@ -1067,7 +1077,7 @@ let transform_signature_item ~config item =
1067
1077
let new_external_type =
1068
1078
Ptyp_constr
1069
1079
( {loc = psig_loc; txt = module_access_name config " componentLike" },
1070
- [ret_props_type; inner_type ] )
1080
+ [ret_props_type; jsx_element_type ~loc: psig_loc ] )
1071
1081
in
1072
1082
let new_structure =
1073
1083
{
0 commit comments