Skip to content

Commit f26d5c9

Browse files
cristianoccristianoc
committed
Adapt arrow type in Types.
1 parent 07c6fb7 commit f26d5c9

19 files changed

+159
-131
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 ({lbl = Optional _}, _tTo, _, _) -> true
35+
| Tarrow (_, 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 ({lbl = Optional s}, tTo, _, _) -> s :: fromTypeExpr tTo
44+
| Tarrow (_, tTo, _, _) -> fromTypeExpr tTo
4545
| Tlink t -> fromTypeExpr t
4646
| Tsubst t -> fromTypeExpr t
4747
| _ -> []

‎analysis/src/CompletionBackEnd.ml

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -978,7 +978,10 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact
978978
| [] -> tRet
979979
| (label, tArg) :: rest ->
980980
let restType = reconstructFunctionType rest tRet in
981-
{typ with desc = Tarrow (label, tArg, restType, Cok, None)}
981+
{
982+
typ with
983+
desc = Tarrow ({lbl = label; typ = tArg}, restType, Cok, None);
984+
}
982985
in
983986
let rec processApply args labels =
984987
match (args, labels) with

‎analysis/src/CompletionJsx.ml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -247,15 +247,16 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
247247
match propsType |> getPropsType with
248248
| Some (path, typeArgs) -> getFields ~path ~typeArgs
249249
| None -> [])
250-
| Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _, _)
250+
| Tarrow
251+
({lbl = Nolabel; typ = {desc = Tconstr (path, typeArgs, _)}}, _, _, _)
251252
when Path.last path = "props" ->
252253
getFields ~path ~typeArgs
253254
| Tconstr (clPath, [{desc = Tconstr (path, typeArgs, _)}; _], _)
254255
when Path.name clPath = "React.componentLike"
255256
&& Path.last path = "props" ->
256257
(* JSX V4 external or interface *)
257258
getFields ~path ~typeArgs
258-
| Tarrow (Nolabel, typ, _, _, _) -> (
259+
| Tarrow ({lbl = Nolabel; typ}, _, _, _) -> (
259260
(* Component without the JSX PPX, like a make fn taking a hand-written
260261
type props. *)
261262
let rec digToConstr typ =

‎analysis/src/CreateInterface.ml

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -124,7 +124,10 @@ let printSignature ~extractor ~signature =
124124
in
125125
match typ.desc with
126126
| Tarrow
127-
(_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _)
127+
( {typ = {desc = Tconstr (Path.Pident propsId, typeArgs, _)}},
128+
retType,
129+
_,
130+
_ )
128131
when Ident.name propsId = "props" ->
129132
Some (typeArgs, retType)
130133
| Tconstr
@@ -175,15 +178,18 @@ let printSignature ~extractor ~signature =
175178
in
176179
{
177180
retType with
178-
desc = Tarrow (lbl, propType, mkFunType rest, Cok, None);
181+
desc = Tarrow ({lbl; typ = propType}, mkFunType rest, Cok, None);
179182
}
180183
in
181184
let funType =
182185
if List.length labelDecls = 0 (* No props *) then
183186
let tUnit =
184187
Ctype.newconstr (Path.Pident (Ident.create "unit")) []
185188
in
186-
{retType with desc = Tarrow (Nolabel, tUnit, retType, Cok, None)}
189+
{
190+
retType with
191+
desc = Tarrow ({lbl = Nolabel; typ = tUnit}, retType, Cok, None);
192+
}
187193
else mkFunType labelDecls
188194
in
189195
sigItemToString

‎analysis/src/Shared.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -48,9 +48,9 @@ let findTypeConstructors (tel : Types.type_expr list) =
4848
| Tconstr (path, args, _) ->
4949
addPath path;
5050
args |> List.iter loop
51-
| Tarrow (_, te1, te2, _, _) ->
52-
loop te1;
53-
loop te2
51+
| Tarrow (arg, ret, _, _) ->
52+
loop arg.typ;
53+
loop ret
5454
| Ttuple tel -> tel |> List.iter loop
5555
| Tnil | Tvar _ | Tobject _ | Tfield _ | Tvariant _ | Tunivar _ | Tpackage _
5656
->

‎analysis/src/TypeUtils.ml

Lines changed: 18 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ let debugLogTypeArgContext {env; typeArgs; typeParams} =
3030
let rec hasTvar (ty : Types.type_expr) : bool =
3131
match ty.desc with
3232
| Tvar _ -> true
33-
| Tarrow (_, ty1, ty2, _, _) -> hasTvar ty1 || hasTvar ty2
33+
| Tarrow (arg, ret, _, _) -> hasTvar arg.typ || hasTvar ret
3434
| Ttuple tyl -> List.exists hasTvar tyl
3535
| Tconstr (_, tyl, _) -> List.exists hasTvar tyl
3636
| Tobject (ty, _) -> hasTvar ty
@@ -135,8 +135,11 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) =
135135
| Tsubst t -> loop t
136136
| Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
137137
| Tnil -> t
138-
| Tarrow (lbl, t1, t2, c, arity) ->
139-
{t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
138+
| Tarrow (arg, ret, c, arity) ->
139+
{
140+
t with
141+
desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
142+
}
140143
| Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
141144
| Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
142145
| Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -188,8 +191,11 @@ let instantiateType2 ?(typeArgContext : typeArgContext option)
188191
| Tsubst t -> loop t
189192
| Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
190193
| Tnil -> t
191-
| Tarrow (lbl, t1, t2, c, arity) ->
192-
{t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
194+
| Tarrow (arg, ret, c, arity) ->
195+
{
196+
t with
197+
desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
198+
}
193199
| Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
194200
| Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
195201
| Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -261,7 +267,7 @@ let extractFunctionType ~env ~package ?(digInto = true) typ =
261267
let rec loop ~env acc (t : Types.type_expr) =
262268
match t.desc with
263269
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
264-
| Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
270+
| Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet
265271
| Tconstr (path, typeArgs, _) when digInto -> (
266272
match References.digConstructor ~env ~package path with
267273
| Some
@@ -280,7 +286,7 @@ let extractFunctionTypeWithEnv ~env ~package typ =
280286
let rec loop ~env acc (t : Types.type_expr) =
281287
match t.desc with
282288
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
283-
| Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
289+
| Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet
284290
| Tconstr (path, typeArgs, _) -> (
285291
match References.digConstructor ~env ~package path with
286292
| Some
@@ -318,8 +324,8 @@ let extractFunctionType2 ?typeArgContext ~env ~package typ =
318324
let rec loop ?typeArgContext ~env acc (t : Types.type_expr) =
319325
match t.desc with
320326
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1
321-
| Tarrow (label, tArg, tRet, _, _) ->
322-
loop ?typeArgContext ~env ((label, tArg) :: acc) tRet
327+
| Tarrow (arg, tRet, _, _) ->
328+
loop ?typeArgContext ~env ((arg.lbl, arg.typ) :: acc) tRet
323329
| Tconstr (path, typeArgs, _) -> (
324330
match References.digConstructor ~env ~package path with
325331
| Some
@@ -895,12 +901,12 @@ let getArgs ~env (t : Types.type_expr) ~full =
895901
match t.desc with
896902
| Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
897903
getArgsLoop ~full ~env ~currentArgumentPosition t1
898-
| Tarrow (Labelled l, tArg, tRet, _, _) ->
904+
| Tarrow ({lbl = Labelled l; typ = tArg}, tRet, _, _) ->
899905
(SharedTypes.Completable.Labelled l, tArg)
900906
:: getArgsLoop ~full ~env ~currentArgumentPosition tRet
901-
| Tarrow (Optional l, tArg, tRet, _, _) ->
907+
| Tarrow ({lbl = Optional l; typ = tArg}, tRet, _, _) ->
902908
(Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet
903-
| Tarrow (Nolabel, tArg, tRet, _, _) ->
909+
| Tarrow ({lbl = Nolabel; typ = tArg}, tRet, _, _) ->
904910
(Unlabelled {argumentPosition = currentArgumentPosition}, tArg)
905911
:: getArgsLoop ~full ~env
906912
~currentArgumentPosition:(currentArgumentPosition + 1)

‎compiler/gentype/TranslateTypeExprFromTypes.ml

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -290,7 +290,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
290290
| Tlink t ->
291291
translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
292292
~rev_args t
293-
| Tarrow (Nolabel, type_expr1, type_expr2, _, arity)
293+
| Tarrow ({lbl = Nolabel; typ = type_expr1}, type_expr2, _, arity)
294294
when arity = None || rev_args = [] ->
295295
let {dependencies; type_} =
296296
type_expr1 |> fun __x ->
@@ -302,8 +302,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
302302
~rev_arg_deps:next_rev_deps
303303
~rev_args:((Nolabel, type_) :: rev_args)
304304
| Tarrow
305-
( ((Labelled lbl | Optional lbl) as label),
306-
type_expr1,
305+
( {lbl = (Labelled lbl | Optional lbl) as label; typ = type_expr1},
307306
type_expr2,
308307
_,
309308
arity )

‎compiler/ml/btype.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -260,7 +260,7 @@ let rec iter_row f row =
260260
let iter_type_expr f ty =
261261
match ty.desc with
262262
| Tvar _ -> ()
263-
| Tarrow (_, ty1, ty2, _, _) ->
263+
| Tarrow ({typ = ty1}, ty2, _, _) ->
264264
f ty1;
265265
f ty2
266266
| Ttuple l -> List.iter f l
@@ -428,8 +428,8 @@ let rec norm_univar ty =
428428

429429
let rec copy_type_desc ?(keep_names = false) f = function
430430
| Tvar _ as ty -> if keep_names then ty else Tvar None
431-
| Tarrow (p, ty1, ty2, c, arity) ->
432-
Tarrow (p, f ty1, f ty2, copy_commu c, arity)
431+
| Tarrow (arg, ret, c, arity) ->
432+
Tarrow ({arg with typ = f arg.typ}, f ret, copy_commu c, arity)
433433
| Ttuple l -> Ttuple (List.map f l)
434434
| Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil)
435435
| Tobject (ty, {contents = Some (p, tl)}) ->

‎compiler/ml/ctype.ml

Lines changed: 39 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -732,9 +732,9 @@ let rec generalize_expansive env var_level visited ty =
732732
else generalize_expansive env var_level visited t)
733733
variance tyl
734734
| Tpackage (_, _, tyl) -> List.iter (generalize_structure var_level) tyl
735-
| Tarrow (_, t1, t2, _, _) ->
736-
generalize_structure var_level t1;
737-
generalize_expansive env var_level visited t2
735+
| Tarrow (arg, ret, _, _) ->
736+
generalize_structure var_level arg.typ;
737+
generalize_expansive env var_level visited ret
738738
| _ -> iter_type_expr (generalize_expansive env var_level visited) ty)
739739

740740
let generalize_expansive env ty =
@@ -1926,11 +1926,11 @@ let rec mcomp type_pairs env t1 t2 =
19261926
TypePairs.add type_pairs (t1', t2') ();
19271927
match (t1'.desc, t2'.desc) with
19281928
| Tvar _, Tvar _ -> assert false
1929-
| Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
1930-
when Asttypes.Noloc.same_arg_label l1 l2
1931-
|| not (is_optional l1 || is_optional l2) ->
1932-
mcomp type_pairs env t1 t2;
1933-
mcomp type_pairs env u1 u2
1929+
| Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
1930+
when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl
1931+
|| not (is_optional arg1.lbl || is_optional arg2.lbl) ->
1932+
mcomp type_pairs env arg1.typ arg2.typ;
1933+
mcomp type_pairs env ret1 ret2
19341934
| Ttuple tl1, Ttuple tl2 -> mcomp_list type_pairs env tl1 tl2
19351935
| Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) ->
19361936
mcomp_type_decl type_pairs env p1 p2 tl1 tl2
@@ -2342,13 +2342,13 @@ and unify3 env t1 t1' t2 t2' =
23422342
| Pattern -> add_type_equality t1' t2');
23432343
try
23442344
(match (d1, d2) with
2345-
| Tarrow (l1, t1, u1, c1, a1), Tarrow (l2, t2, u2, c2, a2)
2345+
| Tarrow (arg1, ret1, c1, a1), Tarrow (arg2, ret2, c2, a2)
23462346
when a1 = a2
2347-
&& (Asttypes.Noloc.same_arg_label l1 l2
2348-
|| (!umode = Pattern && not (is_optional l1 || is_optional l2))
2349-
) -> (
2350-
unify env t1 t2;
2351-
unify env u1 u2;
2347+
&& (Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl
2348+
|| !umode = Pattern
2349+
&& not (is_optional arg1.lbl || is_optional arg2.lbl)) -> (
2350+
unify env arg1.typ arg2.typ;
2351+
unify env ret1 ret2;
23522352
match (commu_repr c1, commu_repr c2) with
23532353
| Clink r, c2 -> set_commu r c2
23542354
| c1, Clink r -> set_commu r c1
@@ -2796,10 +2796,11 @@ let filter_arrow ~env ~arity t l =
27962796
| Tvar _ ->
27972797
let lv = t.level in
27982798
let t1 = newvar2 lv and t2 = newvar2 lv in
2799-
let t' = newty2 lv (Tarrow (l, t1, t2, Cok, arity)) in
2799+
let t' = newty2 lv (Tarrow ({lbl = l; typ = t1}, t2, Cok, arity)) in
28002800
link_type t t';
28012801
(t1, t2)
2802-
| Tarrow (l', t1, t2, _, _) when Asttypes.Noloc.same_arg_label l l' -> (t1, t2)
2802+
| Tarrow (arg, ret, _, _) when Asttypes.Noloc.same_arg_label l arg.lbl ->
2803+
(arg.typ, ret)
28032804
| _ -> raise (Unify [])
28042805

28052806
(* Used by [filter_method]. *)
@@ -2913,10 +2914,10 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
29132914
| Tvar _, _ when may_instantiate inst_nongen t1' ->
29142915
moregen_occur env t1'.level t2;
29152916
link_type t1' t2
2916-
| Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
2917-
when Asttypes.Noloc.same_arg_label l1 l2 ->
2918-
moregen inst_nongen type_pairs env t1 t2;
2919-
moregen inst_nongen type_pairs env u1 u2
2917+
| Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
2918+
when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
2919+
moregen inst_nongen type_pairs env arg1.typ arg2.typ;
2920+
moregen inst_nongen type_pairs env ret1 ret2
29202921
| Ttuple tl1, Ttuple tl2 ->
29212922
moregen_list inst_nongen type_pairs env tl1 tl2
29222923
| Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2
@@ -3183,10 +3184,10 @@ let rec eqtype rename type_pairs subst env t1 t2 =
31833184
if List.exists (fun (_, t) -> t == t2') !subst then
31843185
raise (Unify []);
31853186
subst := (t1', t2') :: !subst)
3186-
| Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
3187-
when Asttypes.Noloc.same_arg_label l1 l2 ->
3188-
eqtype rename type_pairs subst env t1 t2;
3189-
eqtype rename type_pairs subst env u1 u2
3187+
| Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
3188+
when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
3189+
eqtype rename type_pairs subst env arg1.typ arg2.typ;
3190+
eqtype rename type_pairs subst env ret1 ret2
31903191
| Ttuple tl1, Ttuple tl2 ->
31913192
eqtype_list rename type_pairs subst env tl1 tl2
31923193
| Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2
@@ -3396,14 +3397,14 @@ let rec build_subtype env visited loops posi level t =
33963397
(t', Equiv)
33973398
with Not_found -> (t, Unchanged)
33983399
else (t, Unchanged)
3399-
| Tarrow (l, t1, t2, _, a) ->
3400+
| Tarrow (arg, ret, _, a) ->
34003401
if memq_warn t visited then (t, Unchanged)
34013402
else
34023403
let visited = t :: visited in
3403-
let t1', c1 = build_subtype env visited loops (not posi) level t1 in
3404-
let t2', c2 = build_subtype env visited loops posi level t2 in
3404+
let t1, c1 = build_subtype env visited loops (not posi) level arg.typ in
3405+
let t2, c2 = build_subtype env visited loops posi level ret in
34053406
let c = max c1 c2 in
3406-
if c > Unchanged then (newty (Tarrow (l, t1', t2', Cok, a)), c)
3407+
if c > Unchanged then (newty (Tarrow ({arg with typ = t1}, t2, Cok, a)), c)
34073408
else (t, Unchanged)
34083409
| Ttuple tlist ->
34093410
if memq_warn t visited then (t, Unchanged)
@@ -3596,10 +3597,14 @@ let rec subtype_rec env trace t1 t2 cstrs =
35963597
TypePairs.add subtypes (t1, t2) ();
35973598
match (t1.desc, t2.desc) with
35983599
| Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs
3599-
| Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
3600-
when Asttypes.Noloc.same_arg_label l1 l2 ->
3601-
let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in
3602-
subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs
3600+
| Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
3601+
when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
3602+
let cstrs =
3603+
subtype_rec env
3604+
((arg2.typ, arg1.typ) :: trace)
3605+
arg2.typ arg1.typ cstrs
3606+
in
3607+
subtype_rec env ((ret1, ret2) :: trace) ret1 ret2 cstrs
36033608
| Ttuple tl1, Ttuple tl2 ->
36043609
(* TODO(subtype-errors) Tuple as context *)
36053610
subtype_list env trace tl1 tl2 cstrs
@@ -4074,7 +4079,7 @@ let unalias ty =
40744079
(* Return the arity (as for curried functions) of the given type. *)
40754080
let rec arity ty =
40764081
match (repr ty).desc with
4077-
| Tarrow (_, _t1, t2, _, _) -> 1 + arity t2
4082+
| Tarrow (_, ret, _, _) -> 1 + arity ret
40784083
| _ -> 0
40794084

40804085
(* Check whether an abbreviation expands to itself. *)
@@ -4440,5 +4445,5 @@ let maybe_pointer_type env typ =
44404445

44414446
let get_arity env typ =
44424447
match (expand_head env typ).desc with
4443-
| Tarrow (_, _, _, _, arity) -> arity
4448+
| Tarrow (_, _, _, arity) -> arity
44444449
| _ -> None

0 commit comments

Comments
 (0)