Skip to content

Commit 513a1bd

Browse files
cristianoccristianoc
committed
AST: test storing arity in function type
1 parent 55f12e0 commit 513a1bd

Some content is hidden

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

46 files changed

+145
-89
lines changed

‎analysis/src/SignatureHelp.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -128,7 +128,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
128128
| {
129129
(* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *)
130130
Parsetree.ptyp_desc =
131-
Ptyp_arrow (argumentLabel, argumentTypeExpr, nextFunctionExpr);
131+
Ptyp_arrow (argumentLabel, argumentTypeExpr, nextFunctionExpr, _);
132132
ptyp_loc;
133133
} ->
134134
let startOffset =

‎compiler/frontend/ast_compatible.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -96,14 +96,14 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
9696

9797
let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
9898
{
99-
ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b);
99+
ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, None);
100100
ptyp_loc = loc;
101101
ptyp_attributes = attrs;
102102
}
103103

104104
let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
105105
{
106-
ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b);
106+
ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, None);
107107
ptyp_loc = loc;
108108
ptyp_attributes = attrs;
109109
}

‎compiler/frontend/ast_core_type.ml

+4-4
Original file line numberDiff line numberDiff line change
@@ -108,7 +108,7 @@ let make_obj ~loc xs = Typ.object_ ~loc xs Closed
108108
*)
109109
let rec get_uncurry_arity_aux (ty : t) acc =
110110
match ty.ptyp_desc with
111-
| Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc)
111+
| Ptyp_arrow (_, _, new_ty, _) -> get_uncurry_arity_aux new_ty (succ acc)
112112
| Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc
113113
| _ -> acc
114114

@@ -119,7 +119,7 @@ let rec get_uncurry_arity_aux (ty : t) acc =
119119
*)
120120
let get_uncurry_arity (ty : t) =
121121
match ty.ptyp_desc with
122-
| Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
122+
| Ptyp_arrow (_, _, rest, _) -> Some (get_uncurry_arity_aux rest 1)
123123
| _ -> None
124124

125125
let get_curry_arity (ty : t) =
@@ -139,15 +139,15 @@ type param_type = {
139139
let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
140140
Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr; loc} acc ->
141141
{
142-
ptyp_desc = Ptyp_arrow (label, ty, acc);
142+
ptyp_desc = Ptyp_arrow (label, ty, acc, None);
143143
ptyp_loc = loc;
144144
ptyp_attributes = attr;
145145
})
146146

147147
let list_of_arrow (ty : t) : t * param_type list =
148148
let rec aux (ty : t) acc =
149149
match ty.ptyp_desc with
150-
| Ptyp_arrow (label, t1, t2) ->
150+
| Ptyp_arrow (label, t1, t2, _) ->
151151
aux t2
152152
(({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc}
153153
: param_type)

‎compiler/frontend/ast_core_type_class_type.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -69,11 +69,11 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
6969
| {
7070
ptyp_attributes;
7171
ptyp_desc =
72-
( Ptyp_arrow (label, args, body)
72+
( Ptyp_arrow (label, args, body, _)
7373
| Ptyp_constr
7474
(* function$<...> is re-wrapped around only in case Nothing below *)
7575
( {txt = Lident "function$"},
76-
[{ptyp_desc = Ptyp_arrow (label, args, body)}; _] ) );
76+
[{ptyp_desc = Ptyp_arrow (label, args, body, _)}; _] ) );
7777
(* let it go without regard label names,
7878
it will report error later when the label is not empty
7979
*)

‎compiler/frontend/bs_ast_mapper.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -101,7 +101,7 @@ module T = struct
101101
match desc with
102102
| Ptyp_any -> any ~loc ~attrs ()
103103
| Ptyp_var s -> var ~loc ~attrs s
104-
| Ptyp_arrow (lab, t1, t2) ->
104+
| Ptyp_arrow (lab, t1, t2, _) ->
105105
arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
106106
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
107107
| Ptyp_constr (lid, tl) ->

‎compiler/gentype/TranslateCoreType.ml

+3-3
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ let rec translate_arrow_type ~config ~type_vars_gen
5252
~no_function_return_dependencies ~type_env ~rev_arg_deps ~rev_args
5353
(core_type : Typedtree.core_type) =
5454
match core_type.ctyp_desc with
55-
| Ttyp_arrow (Nolabel, core_type1, core_type2) ->
55+
| Ttyp_arrow (Nolabel, core_type1, core_type2, _) ->
5656
let {dependencies; type_} =
5757
core_type1 |> fun __x ->
5858
translateCoreType_ ~config ~type_vars_gen ~type_env __x
@@ -62,8 +62,8 @@ let rec translate_arrow_type ~config ~type_vars_gen
6262
|> translate_arrow_type ~config ~type_vars_gen
6363
~no_function_return_dependencies ~type_env ~rev_arg_deps:next_rev_deps
6464
~rev_args:((Nolabel, type_) :: rev_args)
65-
| Ttyp_arrow (((Labelled lbl | Optional lbl) as label), core_type1, core_type2)
66-
-> (
65+
| Ttyp_arrow
66+
(((Labelled lbl | Optional lbl) as label), core_type1, core_type2, _) -> (
6767
let as_label =
6868
match core_type.ctyp_attributes |> Annotation.get_gentype_as_renaming with
6969
| Some s -> s

‎compiler/ml/ast_helper.ml

+4-3
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,8 @@ module Typ = struct
5454

5555
let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
5656
let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
57-
let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
57+
let arrow ?loc ?attrs ?arity a b c =
58+
mk ?loc ?attrs (Ptyp_arrow (a, b, c, arity))
5859
let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
5960
let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
6061
let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
@@ -81,8 +82,8 @@ module Typ = struct
8182
| Ptyp_var x ->
8283
check_variable var_names t.ptyp_loc x;
8384
Ptyp_var x
84-
| Ptyp_arrow (label, core_type, core_type') ->
85-
Ptyp_arrow (label, loop core_type, loop core_type')
85+
| Ptyp_arrow (label, core_type, core_type', a) ->
86+
Ptyp_arrow (label, loop core_type, loop core_type', a)
8687
| Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
8788
| Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names
8889
->

‎compiler/ml/ast_helper.mli

+7-1
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,13 @@ module Typ : sig
5555
val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type
5656
val var : ?loc:loc -> ?attrs:attrs -> string -> core_type
5757
val arrow :
58-
?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type
58+
?loc:loc ->
59+
?attrs:attrs ->
60+
?arity:int ->
61+
arg_label ->
62+
core_type ->
63+
core_type ->
64+
core_type
5965
val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
6066
val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
6167
val object_ :

‎compiler/ml/ast_iterator.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -96,7 +96,7 @@ module T = struct
9696
sub.attributes sub attrs;
9797
match desc with
9898
| Ptyp_any | Ptyp_var _ -> ()
99-
| Ptyp_arrow (_lab, t1, t2) ->
99+
| Ptyp_arrow (_lab, t1, t2, _) ->
100100
sub.typ sub t1;
101101
sub.typ sub t2
102102
| Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl

‎compiler/ml/ast_mapper.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -93,7 +93,7 @@ module T = struct
9393
match desc with
9494
| Ptyp_any -> any ~loc ~attrs ()
9595
| Ptyp_var s -> var ~loc ~attrs s
96-
| Ptyp_arrow (lab, t1, t2) ->
96+
| Ptyp_arrow (lab, t1, t2, _) ->
9797
arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
9898
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
9999
| Ptyp_constr (lid, tl) ->

‎compiler/ml/ast_mapper_from0.ml

+14-2
Original file line numberDiff line numberDiff line change
@@ -101,8 +101,20 @@ module T = struct
101101
| Ptyp_arrow (lab, t1, t2) ->
102102
arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
103103
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
104-
| Ptyp_constr (lid, tl) ->
105-
constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
104+
| Ptyp_constr (lid, tl) -> (
105+
let typ0 =
106+
constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
107+
in
108+
match typ0.ptyp_desc with
109+
| Ptyp_constr
110+
(lid, [({ptyp_desc = Ptyp_arrow (lbl, t1, t2, _)} as fun_t); t_arity])
111+
when lid.txt = Lident "function$" ->
112+
let arity = Ast_uncurried.arity_from_type t_arity in
113+
let fun_t =
114+
{fun_t with ptyp_desc = Ptyp_arrow (lbl, t1, t2, Some arity)}
115+
in
116+
{typ0 with ptyp_desc = Ptyp_constr (lid, [fun_t; t_arity])}
117+
| _ -> typ0)
106118
| Ptyp_object (l, o) ->
107119
object_ ~loc ~attrs (List.map (object_field sub) l) o
108120
| Ptyp_class () -> assert false

‎compiler/ml/ast_mapper_to0.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -98,7 +98,7 @@ module T = struct
9898
match desc with
9999
| Ptyp_any -> any ~loc ~attrs ()
100100
| Ptyp_var s -> var ~loc ~attrs s
101-
| Ptyp_arrow (lab, t1, t2) ->
101+
| Ptyp_arrow (lab, t1, t2, _) ->
102102
arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
103103
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
104104
| Ptyp_constr (lid, tl) ->

‎compiler/ml/ast_uncurried.ml

+7-1
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,13 @@ let arity_from_type (typ : Parsetree.core_type) =
1515
| Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt
1616
| _ -> assert false
1717

18-
let uncurried_type ~loc ~arity t_arg =
18+
let uncurried_type ~loc ~arity (t_arg : Parsetree.core_type) =
19+
let t_arg =
20+
match t_arg.ptyp_desc with
21+
| Ptyp_arrow (l, t1, t2, _) ->
22+
{t_arg with ptyp_desc = Ptyp_arrow (l, t1, t2, Some arity)}
23+
| _ -> assert false
24+
in
1925
let t_arity = arity_type ~loc arity in
2026
Ast_helper.Typ.constr ~loc {txt = Lident "function$"; loc} [t_arg; t_arity]
2127

‎compiler/ml/asttypes.ml

+2
Original file line numberDiff line numberDiff line change
@@ -46,6 +46,8 @@ type arg_label =
4646
| Labelled of string (* label:T -> ... *)
4747
| Optional of string (* ?label:T -> ... *)
4848

49+
type arity = int option
50+
4951
type 'a loc = 'a Location.loc = {txt: 'a; loc: Location.t}
5052

5153
type variance = Covariant | Contravariant | Invariant

‎compiler/ml/depend.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -105,7 +105,7 @@ let rec add_type bv ty =
105105
match ty.ptyp_desc with
106106
| Ptyp_any -> ()
107107
| Ptyp_var _ -> ()
108-
| Ptyp_arrow (_, t1, t2) ->
108+
| Ptyp_arrow (_, t1, t2, _) ->
109109
add_type bv t1;
110110
add_type bv t2
111111
| Ptyp_tuple tl -> List.iter (add_type bv) tl

‎compiler/ml/parsetree.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ and core_type = {
7676
and core_type_desc =
7777
| Ptyp_any (* _ *)
7878
| Ptyp_var of string (* 'a *)
79-
| Ptyp_arrow of arg_label * core_type * core_type
79+
| Ptyp_arrow of arg_label * core_type * core_type * arity
8080
(* T1 -> T2 Simple
8181
~l:T1 -> T2 Labelled
8282
?l:T1 -> T2 Optional

‎compiler/ml/pprintast.ml

+3-3
Original file line numberDiff line numberDiff line change
@@ -247,9 +247,9 @@ and core_type ctxt f x =
247247
(attributes ctxt) x.ptyp_attributes
248248
end
249249
else match x.ptyp_desc with
250-
| Ptyp_arrow (l, ct1, ct2) ->
251-
pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
252-
(type_with_label ctxt) (l,ct1) (core_type ctxt) ct2
250+
| Ptyp_arrow (l, ct1, ct2, a) ->
251+
pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *)
252+
(type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 (match a with | None -> "" | Some n -> " (a:" ^ string_of_int n ^ ")")
253253
| Ptyp_alias (ct, s) ->
254254
pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s
255255
| Ptyp_poly ([], ct) ->

‎compiler/ml/printast.ml

+6-1
Original file line numberDiff line numberDiff line change
@@ -122,8 +122,13 @@ let rec core_type i ppf x =
122122
match x.ptyp_desc with
123123
| Ptyp_any -> line i ppf "Ptyp_any\n"
124124
| Ptyp_var s -> line i ppf "Ptyp_var %s\n" s
125-
| Ptyp_arrow (l, ct1, ct2) ->
125+
| Ptyp_arrow (l, ct1, ct2, a) ->
126126
line i ppf "Ptyp_arrow\n";
127+
let () =
128+
match a with
129+
| None -> ()
130+
| Some n -> line i ppf "arity = %d\n" n
131+
in
127132
arg_label i ppf l;
128133
core_type i ppf ct1;
129134
core_type i ppf ct2

‎compiler/ml/printtyped.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ let rec core_type i ppf x =
149149
match x.ctyp_desc with
150150
| Ttyp_any -> line i ppf "Ttyp_any\n"
151151
| Ttyp_var s -> line i ppf "Ttyp_var %s\n" s
152-
| Ttyp_arrow (l, ct1, ct2) ->
152+
| Ttyp_arrow (l, ct1, ct2, _) ->
153153
line i ppf "Ttyp_arrow\n";
154154
arg_label i ppf l;
155155
core_type i ppf ct1;

‎compiler/ml/tast_iterator.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -295,7 +295,7 @@ let typ sub {ctyp_desc; ctyp_env; _} =
295295
match ctyp_desc with
296296
| Ttyp_any -> ()
297297
| Ttyp_var _ -> ()
298-
| Ttyp_arrow (_, ct1, ct2) ->
298+
| Ttyp_arrow (_, ct1, ct2, _) ->
299299
sub.typ sub ct1;
300300
sub.typ sub ct2
301301
| Ttyp_tuple list -> List.iter (sub.typ sub) list

‎compiler/ml/tast_mapper.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -362,8 +362,8 @@ let typ sub x =
362362
let ctyp_desc =
363363
match x.ctyp_desc with
364364
| (Ttyp_any | Ttyp_var _) as d -> d
365-
| Ttyp_arrow (label, ct1, ct2) ->
366-
Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
365+
| Ttyp_arrow (label, ct1, ct2, arity) ->
366+
Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2, arity)
367367
| Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
368368
| Ttyp_constr (path, lid, list) ->
369369
Ttyp_constr (path, lid, List.map (sub.typ sub) list)

‎compiler/ml/typecore.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -1896,7 +1896,7 @@ and is_nonexpansive_opt = function
18961896
18971897
let rec approx_type env sty =
18981898
match sty.ptyp_desc with
1899-
| Ptyp_arrow (p, _, sty) ->
1899+
| Ptyp_arrow (p, _, sty, _) ->
19001900
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
19011901
newty (Tarrow (p, ty1, approx_type env sty, Cok))
19021902
| Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args))

‎compiler/ml/typedecl.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -1790,7 +1790,7 @@ let transl_exception env sext =
17901790

17911791
let rec arity_from_arrow_type env core_type ty =
17921792
match (core_type.ptyp_desc, (Ctype.repr ty).desc) with
1793-
| Ptyp_arrow (_, _, ct2), Tarrow (_, _, t2, _) ->
1793+
| Ptyp_arrow (_, _, ct2, _), Tarrow (_, _, t2, _) ->
17941794
1 + arity_from_arrow_type env ct2 t2
17951795
| Ptyp_arrow _, _ | _, Tarrow _ -> assert false
17961796
| _ -> 0

‎compiler/ml/typedtree.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -313,7 +313,7 @@ and core_type = {
313313
and core_type_desc =
314314
| Ttyp_any
315315
| Ttyp_var of string
316-
| Ttyp_arrow of arg_label * core_type * core_type
316+
| Ttyp_arrow of arg_label * core_type * core_type * arity
317317
| Ttyp_tuple of core_type list
318318
| Ttyp_constr of Path.t * Longident.t loc * core_type list
319319
| Ttyp_object of object_field list * closed_flag

‎compiler/ml/typedtree.mli

+1-1
Original file line numberDiff line numberDiff line change
@@ -419,7 +419,7 @@ and core_type = {
419419
and core_type_desc =
420420
| Ttyp_any
421421
| Ttyp_var of string
422-
| Ttyp_arrow of arg_label * core_type * core_type
422+
| Ttyp_arrow of arg_label * core_type * core_type * arity
423423
| Ttyp_tuple of core_type list
424424
| Ttyp_constr of Path.t * Longident.t loc * core_type list
425425
| Ttyp_object of object_field list * closed_flag

‎compiler/ml/typedtreeIter.ml

+1-1
Original file line numberDiff line numberDiff line change
@@ -383,7 +383,7 @@ end = struct
383383
(match ct.ctyp_desc with
384384
| Ttyp_any -> ()
385385
| Ttyp_var _ -> ()
386-
| Ttyp_arrow (_label, ct1, ct2) ->
386+
| Ttyp_arrow (_label, ct1, ct2, _) ->
387387
iter_core_type ct1;
388388
iter_core_type ct2
389389
| Ttyp_tuple list -> List.iter iter_core_type list

‎compiler/ml/typetexp.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -327,7 +327,7 @@ and transl_type_aux env policy styp =
327327
v)
328328
in
329329
ctyp (Ttyp_var name) ty
330-
| Ptyp_arrow (l, st1, st2) ->
330+
| Ptyp_arrow (l, st1, st2, arity) ->
331331
let cty1 = transl_type env policy st1 in
332332
let cty2 = transl_type env policy st2 in
333333
let ty1 = cty1.ctyp_type in
@@ -337,7 +337,7 @@ and transl_type_aux env policy styp =
337337
else ty1
338338
in
339339
let ty = newty (Tarrow (l, ty1, cty2.ctyp_type, Cok)) in
340-
ctyp (Ttyp_arrow (l, cty1, cty2)) ty
340+
ctyp (Ttyp_arrow (l, cty1, cty2, arity)) ty
341341
| Ptyp_tuple stl ->
342342
assert (List.length stl >= 2);
343343
let ctys = List.map (transl_type env policy) stl in

‎compiler/ml/untypeast.ml

+2-2
Original file line numberDiff line numberDiff line change
@@ -511,8 +511,8 @@ let core_type sub ct =
511511
match ct.ctyp_desc with
512512
| Ttyp_any -> Ptyp_any
513513
| Ttyp_var s -> Ptyp_var s
514-
| Ttyp_arrow (label, ct1, ct2) ->
515-
Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
514+
| Ttyp_arrow (label, ct1, ct2, arity) ->
515+
Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2, arity)
516516
| Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
517517
| Ttyp_constr (_path, lid, list) ->
518518
Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list)

0 commit comments

Comments
 (0)