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‎

Lines changed: 4 additions & 4 deletions
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‎

Lines changed: 1 addition & 1 deletion
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‎

Lines changed: 2 additions & 2 deletions
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‎

Lines changed: 7 additions & 3 deletions
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‎

Lines changed: 1 addition & 1 deletion
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‎

Lines changed: 10 additions & 10 deletions
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‎

Lines changed: 4 additions & 2 deletions
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‎

Lines changed: 6 additions & 5 deletions
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‎

Lines changed: 8 additions & 1 deletion
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‎

Lines changed: 2 additions & 1 deletion
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

0 commit comments

Comments
 (0)