Skip to content

Commit a12fc3c

Browse files
cristianoccristianoc
committed
WIP: extend types and type propagation with arity
This needs some info from function definition that is not readily available. Better to postpone this until arity is explicit in function definitions.
1 parent d19614e commit a12fc3c

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

61 files changed

+438
-334
lines changed

‎analysis/reanalyze/src/DeadOptionalArgs.ml

+4-4
Original file line numberDiff line numberDiff line change
@@ -31,17 +31,17 @@ let addFunctionReference ~(locFrom : Location.t) ~(locTo : Location.t) =
3131
let rec hasOptionalArgs (texpr : Types.type_expr) =
3232
match texpr.desc with
3333
| _ when not (active ()) -> false
34-
| Tarrow (Optional _, _tFrom, _tTo, _) -> true
35-
| Tarrow (_, _tFrom, tTo, _) -> hasOptionalArgs tTo
34+
| Tarrow (Optional _, _tFrom, _tTo, _, _) -> true
35+
| Tarrow (_, _tFrom, tTo, _, _) -> hasOptionalArgs tTo
3636
| Tlink t -> hasOptionalArgs t
3737
| Tsubst t -> hasOptionalArgs t
3838
| _ -> false
3939

4040
let rec fromTypeExpr (texpr : Types.type_expr) =
4141
match texpr.desc with
4242
| _ when not (active ()) -> []
43-
| Tarrow (Optional s, _tFrom, tTo, _) -> s :: fromTypeExpr tTo
44-
| Tarrow (_, _tFrom, tTo, _) -> fromTypeExpr tTo
43+
| Tarrow (Optional s, _tFrom, tTo, _, _) -> s :: fromTypeExpr tTo
44+
| Tarrow (_, _tFrom, tTo, _, _) -> fromTypeExpr tTo
4545
| Tlink t -> fromTypeExpr t
4646
| Tsubst t -> fromTypeExpr t
4747
| _ -> []

‎analysis/src/CompletionBackEnd.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -898,7 +898,7 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact
898898
| [] -> tRet
899899
| (label, tArg) :: rest ->
900900
let restType = reconstructFunctionType rest tRet in
901-
{typ with desc = Tarrow (label, tArg, restType, Cok)}
901+
{typ with desc = Tarrow (label, tArg, restType, Cok, None)}
902902
in
903903
let rec processApply args labels =
904904
match (args, labels) with

‎analysis/src/CompletionJsx.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -251,15 +251,15 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
251251
match propsType |> getPropsType with
252252
| Some (path, typeArgs) -> getFields ~path ~typeArgs
253253
| None -> [])
254-
| Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _)
254+
| Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _, _)
255255
when Path.last path = "props" ->
256256
getFields ~path ~typeArgs
257257
| Tconstr (clPath, [{desc = Tconstr (path, typeArgs, _)}; _], _)
258258
when Path.name clPath = "React.componentLike"
259259
&& Path.last path = "props" ->
260260
(* JSX V4 external or interface *)
261261
getFields ~path ~typeArgs
262-
| Tarrow (Nolabel, typ, _, _) -> (
262+
| Tarrow (Nolabel, typ, _, _, _) -> (
263263
(* Component without the JSX PPX, like a make fn taking a hand-written
264264
type props. *)
265265
let rec digToConstr typ =

‎analysis/src/CreateInterface.ml

+7-3
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,8 @@ let printSignature ~extractor ~signature =
124124
in
125125
match typ.desc with
126126
| Tconstr (Pident {name = "function$"}, [typ; _], _) -> getComponentType typ
127-
| Tarrow (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _)
127+
| Tarrow
128+
(_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _)
128129
when Ident.name propsId = "props" ->
129130
Some (typeArgs, retType)
130131
| Tconstr
@@ -173,14 +174,17 @@ let printSignature ~extractor ~signature =
173174
if labelDecl.ld_optional then Asttypes.Optional lblName
174175
else Labelled lblName
175176
in
176-
{retType with desc = Tarrow (lbl, propType, mkFunType rest, Cok)}
177+
{
178+
retType with
179+
desc = Tarrow (lbl, propType, mkFunType rest, Cok, None);
180+
}
177181
in
178182
let funType =
179183
if List.length labelDecls = 0 (* No props *) then
180184
let tUnit =
181185
Ctype.newconstr (Path.Pident (Ident.create "unit")) []
182186
in
183-
{retType with desc = Tarrow (Nolabel, tUnit, retType, Cok)}
187+
{retType with desc = Tarrow (Nolabel, tUnit, retType, Cok, None)}
184188
else mkFunType labelDecls
185189
in
186190
sigItemToString

‎analysis/src/Shared.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ let findTypeConstructors (tel : Types.type_expr list) =
5252
| Tconstr (path, args, _) ->
5353
addPath path;
5454
args |> List.iter loop
55-
| Tarrow (_, te1, te2, _) ->
55+
| Tarrow (_, te1, te2, _, _) ->
5656
loop te1;
5757
loop te2
5858
| Ttuple tel -> tel |> List.iter loop

‎analysis/src/TypeUtils.ml

+10-10
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ let debugLogTypeArgContext {env; typeArgs; typeParams} =
1010
let rec hasTvar (ty : Types.type_expr) : bool =
1111
match ty.desc with
1212
| Tvar _ -> true
13-
| Tarrow (_, ty1, ty2, _) -> hasTvar ty1 || hasTvar ty2
13+
| Tarrow (_, ty1, ty2, _, _) -> hasTvar ty1 || hasTvar ty2
1414
| Ttuple tyl -> List.exists hasTvar tyl
1515
| Tconstr (_, tyl, _) -> List.exists hasTvar tyl
1616
| Tobject (ty, _) -> hasTvar ty
@@ -116,8 +116,8 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) =
116116
| Tsubst t -> loop t
117117
| Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
118118
| Tnil -> t
119-
| Tarrow (lbl, t1, t2, c) ->
120-
{t with desc = Tarrow (lbl, loop t1, loop t2, c)}
119+
| Tarrow (lbl, t1, t2, c, arity) ->
120+
{t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
121121
| Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
122122
| Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
123123
| Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -169,8 +169,8 @@ let instantiateType2 ?(typeArgContext : typeArgContext option)
169169
| Tsubst t -> loop t
170170
| Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
171171
| Tnil -> t
172-
| Tarrow (lbl, t1, t2, c) ->
173-
{t with desc = Tarrow (lbl, loop t1, loop t2, c)}
172+
| Tarrow (lbl, t1, t2, c, arity) ->
173+
{t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
174174
| Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
175175
| Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
176176
| Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -242,7 +242,7 @@ let rec extractFunctionType ~env ~package typ =
242242
let rec loop ~env acc (t : Types.type_expr) =
243243
match t.desc with
244244
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
245-
| Tarrow (label, tArg, tRet, _) -> loop ~env ((label, tArg) :: acc) tRet
245+
| Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
246246
| Tconstr (Pident {name = "function$"}, [t; _], _) ->
247247
extractFunctionType ~env ~package t
248248
| Tconstr (path, typeArgs, _) -> (
@@ -281,7 +281,7 @@ let rec extractFunctionType2 ?typeArgContext ~env ~package typ =
281281
let rec loop ?typeArgContext ~env acc (t : Types.type_expr) =
282282
match t.desc with
283283
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1
284-
| Tarrow (label, tArg, tRet, _) ->
284+
| Tarrow (label, tArg, tRet, _, _) ->
285285
loop ?typeArgContext ~env ((label, tArg) :: acc) tRet
286286
| Tconstr (Pident {name = "function$"}, [t; _], _) ->
287287
extractFunctionType2 ?typeArgContext ~env ~package t
@@ -912,12 +912,12 @@ let getArgs ~env (t : Types.type_expr) ~full =
912912
| Tpoly (t1, [])
913913
| Tconstr (Pident {name = "function$"}, [t1; _], _) ->
914914
getArgsLoop ~full ~env ~currentArgumentPosition t1
915-
| Tarrow (Labelled l, tArg, tRet, _) ->
915+
| Tarrow (Labelled l, tArg, tRet, _, _) ->
916916
(SharedTypes.Completable.Labelled l, tArg)
917917
:: getArgsLoop ~full ~env ~currentArgumentPosition tRet
918-
| Tarrow (Optional l, tArg, tRet, _) ->
918+
| Tarrow (Optional l, tArg, tRet, _, _) ->
919919
(Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet
920-
| Tarrow (Nolabel, tArg, tRet, _) ->
920+
| Tarrow (Nolabel, tArg, tRet, _, _) ->
921921
(Unlabelled {argumentPosition = currentArgumentPosition}, tArg)
922922
:: getArgsLoop ~full ~env
923923
~currentArgumentPosition:(currentArgumentPosition + 1)

‎compiler/frontend/ast_comb.ml

+4-2
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,9 @@ let tuple_type_pair ?loc kind arity =
4040
match kind with
4141
| `Run -> (ty, [], ty)
4242
| `Make ->
43-
(Ast_compatible.arrow ?loc (Ast_literal.type_unit ?loc ()) ty, [], ty)
43+
( Ast_compatible.arrow ?loc ~arity:None (Ast_literal.type_unit ?loc ()) ty,
44+
[],
45+
ty )
4446
else
4547
let number = arity + 1 in
4648
let tys =
@@ -50,7 +52,7 @@ let tuple_type_pair ?loc kind arity =
5052
match tys with
5153
| result :: rest ->
5254
( Ext_list.reduce_from_left tys (fun r arg ->
53-
Ast_compatible.arrow ?loc arg r),
55+
Ast_compatible.arrow ?loc ~arity:None arg r),
5456
List.rev rest,
5557
result )
5658
| [] -> assert false

‎compiler/frontend/ast_compatible.ml

+6-5
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,8 @@ open Parsetree
3030

3131
let default_loc = Location.none
3232

33-
let arrow ?loc ?attrs a b = Ast_helper.Typ.arrow ?loc ?attrs Nolabel a b
33+
let arrow ?loc ?attrs ~arity a b =
34+
Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b
3435

3536
let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
3637
(args : expression list) : expression =
@@ -94,16 +95,16 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
9495
Pexp_apply (fn, Ext_list.map args (fun (l, a) -> (Asttypes.Labelled l, a)));
9596
}
9697

97-
let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
98+
let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type =
9899
{
99-
ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, None);
100+
ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, arity);
100101
ptyp_loc = loc;
101102
ptyp_attributes = attrs;
102103
}
103104

104-
let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
105+
let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s a b : core_type =
105106
{
106-
ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, None);
107+
ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, arity);
107108
ptyp_loc = loc;
108109
ptyp_attributes = attrs;
109110
}

‎compiler/frontend/ast_compatible.mli

+8-1
Original file line numberDiff line numberDiff line change
@@ -90,11 +90,17 @@ val fun_ :
9090
expression *)
9191

9292
val arrow :
93-
?loc:Location.t -> ?attrs:attrs -> core_type -> core_type -> core_type
93+
?loc:Location.t ->
94+
?attrs:attrs ->
95+
arity:Asttypes.arity ->
96+
core_type ->
97+
core_type ->
98+
core_type
9499

95100
val label_arrow :
96101
?loc:Location.t ->
97102
?attrs:attrs ->
103+
arity:Asttypes.arity ->
98104
string ->
99105
core_type ->
100106
core_type ->
@@ -103,6 +109,7 @@ val label_arrow :
103109
val opt_arrow :
104110
?loc:Location.t ->
105111
?attrs:attrs ->
112+
arity:Asttypes.arity ->
106113
string ->
107114
core_type ->
108115
core_type ->

‎compiler/frontend/ast_core_type.ml

+2-1
Original file line numberDiff line numberDiff line change
@@ -95,7 +95,8 @@ let from_labels ~loc arity labels : t =
9595
in
9696
Ext_list.fold_right2 labels tyvars result_type
9797
(fun label (* {loc ; txt = label }*) tyvar acc ->
98-
Ast_compatible.label_arrow ~loc:label.loc label.txt tyvar acc)
98+
Ast_compatible.label_arrow ~loc:label.loc ~arity:(Some arity) label.txt
99+
tyvar acc)
99100

100101
let make_obj ~loc xs = Typ.object_ ~loc xs Closed
101102

‎compiler/frontend/ast_derive_abstract.ml

+10-7
Original file line numberDiff line numberDiff line change
@@ -84,7 +84,8 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
8484
Ext_list.fold_right label_declarations
8585
( [],
8686
(if has_optional_field then
87-
Ast_compatible.arrow ~loc (Ast_literal.type_unit ()) core_type
87+
Ast_compatible.arrow ~loc ~arity:None (Ast_literal.type_unit ())
88+
core_type
8889
else core_type),
8990
[] )
9091
(fun ({
@@ -106,15 +107,17 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
106107
let maker, acc =
107108
if is_optional then
108109
let optional_type = Ast_core_type.lift_option_type pld_type in
109-
( Ast_compatible.opt_arrow ~loc:pld_loc label_name pld_type maker,
110+
( Ast_compatible.opt_arrow ~loc:pld_loc ~arity:None label_name
111+
pld_type maker,
110112
Val.mk ~loc:pld_loc
111113
(if light then pld_name
112114
else {pld_name with txt = pld_name.txt ^ "Get"})
113115
~attrs:get_optional_attrs ~prim
114-
(Ast_compatible.arrow ~loc core_type optional_type)
116+
(Ast_compatible.arrow ~loc ~arity:None core_type optional_type)
115117
:: acc )
116118
else
117-
( Ast_compatible.label_arrow ~loc:pld_loc label_name pld_type maker,
119+
( Ast_compatible.label_arrow ~loc:pld_loc ~arity:None label_name
120+
pld_type maker,
118121
Val.mk ~loc:pld_loc
119122
(if light then pld_name
120123
else {pld_name with txt = pld_name.txt ^ "Get"})
@@ -124,15 +127,15 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
124127
External_ffi_types.ffi_bs_as_prims
125128
[External_arg_spec.dummy] Return_identity
126129
(Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
127-
(Ast_compatible.arrow ~loc core_type pld_type)
130+
(Ast_compatible.arrow ~loc ~arity:None core_type pld_type)
128131
:: acc )
129132
in
130133
let is_current_field_mutable = pld_mutable = Mutable in
131134
let acc =
132135
if is_current_field_mutable then
133136
let setter_type =
134-
Ast_compatible.arrow core_type
135-
(Ast_compatible.arrow pld_type (* setter *)
137+
Ast_compatible.arrow ~arity:None core_type
138+
(Ast_compatible.arrow ~arity:None pld_type (* setter *)
136139
(Ast_literal.type_unit ()))
137140
in
138141
Val.mk ~loc:pld_loc

‎compiler/frontend/ast_derive_js_mapper.ml

+5-4
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,7 @@ let erase_type_str =
6767
Str.primitive
6868
(Val.mk ~prim:["%identity"]
6969
{loc = noloc; txt = erase_type_lit}
70-
(Ast_compatible.arrow any any))
70+
(Ast_compatible.arrow ~arity:None any any))
7171

7272
let unsafe_index = "_index"
7373

@@ -77,7 +77,8 @@ let unsafe_index_get =
7777
(Val.mk ~prim:[""]
7878
{loc = noloc; txt = unsafe_index}
7979
~attrs:[Ast_attributes.get_index]
80-
(Ast_compatible.arrow any (Ast_compatible.arrow any any)))
80+
(Ast_compatible.arrow ~arity:None any
81+
(Ast_compatible.arrow ~arity:None any any)))
8182

8283
let unsafe_index_get_exp = Exp.ident {loc = noloc; txt = Lident unsafe_index}
8384

@@ -130,7 +131,7 @@ let app2 = Ast_compatible.app2
130131

131132
let ( ->~ ) a b =
132133
Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
133-
(Ast_compatible.arrow a b)
134+
(Ast_compatible.arrow ~arity:(Some 1) a b)
134135

135136
let raise_when_not_found_ident =
136137
Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -295,7 +296,7 @@ let init () =
295296
let to_js_type result =
296297
Ast_comb.single_non_rec_val pat_to_js
297298
(Ast_uncurried.uncurried_type ~loc:Location.none ~arity:1
298-
(Ast_compatible.arrow core_type result))
299+
(Ast_compatible.arrow ~arity:(Some 1) core_type result))
299300
in
300301
let new_type, new_tdcl =
301302
U.new_type_of_type_declaration tdcl ("abs_" ^ name)

‎compiler/frontend/ast_derive_projector.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -140,7 +140,7 @@ let init () =
140140
| Ptype_record label_declarations ->
141141
Ext_list.map label_declarations (fun {pld_name; pld_type} ->
142142
Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
143-
(Ast_compatible.arrow core_type pld_type
143+
(Ast_compatible.arrow ~arity:None core_type pld_type
144144
(*arity will alwys be 1 since these are single param functions*)
145145
|> handle_uncurried_type_tranform ~arity:1
146146
~loc:pld_name.loc))
@@ -169,7 +169,7 @@ let init () =
169169
Ast_comb.single_non_rec_val ?attrs:gentype_attrs
170170
{loc; txt = Ext_string.uncapitalize_ascii con_name}
171171
(Ext_list.fold_right pcd_args annotate_type (fun x acc ->
172-
Ast_compatible.arrow x acc)
172+
Ast_compatible.arrow ~arity:None x acc)
173173
|> handle_uncurried_type_tranform ~arity ~loc))
174174
| Ptype_open | Ptype_abstract ->
175175
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;

0 commit comments

Comments
 (0)