Skip to content

Commit 5a59871

Browse files
cristianoccristianoc
committed
Store location directly in the label on Ptyp_arrow instead of a separate field.
1 parent 514bc12 commit 5a59871

28 files changed

+113
-147
lines changed

‎analysis/src/SignatureHelp.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -130,7 +130,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
130130
(* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *)
131131
let endOffset =
132132
match argumentLabel with
133-
| Asttypes.Optional _ -> endOffset + 2
133+
| Asttypes.Opt _ -> endOffset + 2
134134
| _ -> endOffset
135135
in
136136
extractParams nextFunctionExpr
@@ -474,6 +474,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads =
474474
parameters =
475475
parameters
476476
|> List.map (fun (argLabel, start, end_) ->
477+
let argLabel = Asttypes.to_arg_label argLabel in
477478
let paramArgCount = !paramUnlabelledArgCount in
478479
paramUnlabelledArgCount := paramArgCount + 1;
479480
let unlabelledArgCount = ref 0 in

‎compiler/frontend/ast_compatible.ml

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,7 @@ open Parsetree
3131
let default_loc = Location.none
3232

3333
let arrow ?loc ?attrs ~arity a b =
34-
Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b
34+
Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolbl a b
3535

3636
let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
3737
(args : expression list) : expression =
@@ -124,20 +124,20 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
124124
};
125125
}
126126

127-
let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type
128-
=
127+
let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret :
128+
core_type =
129129
{
130130
ptyp_desc =
131-
Ptyp_arrow {lbl = Labelled s; lbl_loc = Location.none; arg; ret; arity};
131+
Ptyp_arrow {lbl = Asttypes.Lbl {txt; loc = default_loc}; arg; ret; arity};
132132
ptyp_loc = loc;
133133
ptyp_attributes = attrs;
134134
}
135135

136-
let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity s arg ret : core_type =
136+
let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret : core_type
137+
=
137138
{
138139
ptyp_desc =
139-
Ptyp_arrow
140-
{lbl = Asttypes.Optional s; lbl_loc = Location.none; arg; ret; arity};
140+
Ptyp_arrow {lbl = Asttypes.Opt {txt; loc = default_loc}; arg; ret; arity};
141141
ptyp_loc = loc;
142142
ptyp_attributes = attrs;
143143
}

‎compiler/frontend/ast_core_type.ml

Lines changed: 3 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -131,7 +131,7 @@ let get_curry_arity (ty : t) =
131131
let is_arity_one ty = get_curry_arity ty = 1
132132

133133
type param_type = {
134-
label: Asttypes.arg_label;
134+
label: Asttypes.arg_label_loc;
135135
ty: Parsetree.core_type;
136136
attr: Parsetree.attributes;
137137
loc: loc;
@@ -142,15 +142,7 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
142142
Ext_list.fold_right new_arg_types_ty result
143143
(fun {label; ty; attr; loc} acc ->
144144
{
145-
ptyp_desc =
146-
Ptyp_arrow
147-
{
148-
lbl = label;
149-
lbl_loc = Location.none;
150-
arg = ty;
151-
ret = acc;
152-
arity = None;
153-
};
145+
ptyp_desc = Ptyp_arrow {lbl = label; arg = ty; ret = acc; arity = None};
154146
ptyp_loc = loc;
155147
ptyp_attributes = attr;
156148
})
@@ -179,5 +171,5 @@ let list_of_arrow (ty : t) : t * param_type list =
179171
let add_last_obj (ty : t) (obj : t) =
180172
let result, params = list_of_arrow ty in
181173
mk_fn_type
182-
(params @ [{label = Nolabel; ty = obj; attr = []; loc = obj.ptyp_loc}])
174+
(params @ [{label = Nolbl; ty = obj; attr = []; loc = obj.ptyp_loc}])
183175
result

‎compiler/frontend/ast_core_type.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ val get_uncurry_arity : t -> int option
4848
*)
4949

5050
type param_type = {
51-
label: Asttypes.arg_label;
51+
label: Asttypes.arg_label_loc;
5252
ty: t;
5353
attr: Parsetree.attributes;
5454
loc: Location.t;

‎compiler/frontend/ast_core_type_class_type.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -106,7 +106,7 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
106106
| Meth_callback attr, attrs -> (attrs, attr +> ty)
107107
in
108108
Ast_compatible.object_field name attrs
109-
(Ast_typ_uncurry.to_uncurry_type loc self Nolabel core_type
109+
(Ast_typ_uncurry.to_uncurry_type loc self Nolbl core_type
110110
(Ast_literal.type_unit ~loc ()))
111111
in
112112
let not_getter_setter ty =

‎compiler/frontend/ast_exp_handle_external.ml

Lines changed: 8 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -43,8 +43,7 @@ let handle_external loc (x : string) : Parsetree.expression =
4343
str_exp with
4444
pexp_desc =
4545
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
46-
~pval_type:
47-
(Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
46+
~pval_type:(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
4847
[str_exp];
4948
}
5049
in
@@ -70,8 +69,7 @@ let handle_debugger loc (payload : Ast_payload.t) =
7069
| PStr [] ->
7170
Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
7271
~pval_type:
73-
(Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ())
74-
(Ast_literal.type_unit ()))
72+
(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Ast_literal.type_unit ()))
7573
[Ast_literal.val_unit ~loc ()]
7674
| _ ->
7775
Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments"
@@ -95,8 +93,7 @@ let handle_raw ~kind loc payload =
9593
exp with
9694
pexp_desc =
9795
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
98-
~pval_type:
99-
(Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
96+
~pval_type:(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
10097
[exp];
10198
pexp_attributes =
10299
(match !is_function with
@@ -123,11 +120,11 @@ let handle_ffi ~loc ~payload =
123120
let any = Ast_helper.Typ.any ~loc:e.pexp_loc () in
124121
let unit = Ast_literal.type_unit ~loc () in
125122
let rec arrow ~arity =
126-
if arity = 0 then Ast_helper.Typ.arrow ~arity:None ~loc Nolabel unit any
123+
if arity = 0 then Ast_helper.Typ.arrow ~arity:None ~loc Nolbl unit any
127124
else if arity = 1 then
128-
Ast_helper.Typ.arrow ~arity:None ~loc Nolabel any any
125+
Ast_helper.Typ.arrow ~arity:None ~loc Nolbl any any
129126
else
130-
Ast_helper.Typ.arrow ~loc ~arity:None Nolabel any
127+
Ast_helper.Typ.arrow ~loc ~arity:None Nolbl any
131128
(arrow ~arity:(arity - 1))
132129
in
133130
match !is_function with
@@ -146,7 +143,7 @@ let handle_ffi ~loc ~payload =
146143
pexp_desc =
147144
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
148145
~pval_type:
149-
(Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
146+
(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
150147
[exp];
151148
pexp_attributes =
152149
(match !is_function with
@@ -163,7 +160,7 @@ let handle_raw_structure loc payload =
163160
pexp_desc =
164161
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
165162
~pval_type:
166-
(Typ.arrow ~arity:(Some 1) Nolabel (Typ.any ()) (Typ.any ()))
163+
(Typ.arrow ~arity:(Some 1) Nolbl (Typ.any ()) (Typ.any ()))
167164
[exp];
168165
}
169166
| None ->

‎compiler/frontend/ast_external_process.ml

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -462,7 +462,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
462462
let ty = param_type.ty in
463463
let new_arg_label, new_arg_types, output_tys =
464464
match arg_label with
465-
| Nolabel -> (
465+
| Nolbl -> (
466466
match ty.ptyp_desc with
467467
| Ptyp_constr ({txt = Lident "unit"}, []) ->
468468
( External_arg_spec.empty_kind Extern_unit,
@@ -471,7 +471,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
471471
| _ ->
472472
Location.raise_errorf ~loc
473473
"expect label, optional, or unit here")
474-
| Labelled label -> (
474+
| Lbl {txt = label} -> (
475475
let field_name =
476476
match
477477
Ast_attributes.iter_process_bs_string_as param_type.attr
@@ -530,7 +530,7 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string)
530530
| Unwrap ->
531531
Location.raise_errorf ~loc
532532
"%@obj label %s does not support %@unwrap arguments" label)
533-
| Optional label -> (
533+
| Opt {txt = label} -> (
534534
let field_name =
535535
match
536536
Ast_attributes.iter_process_bs_string_as param_type.attr
@@ -964,10 +964,10 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
964964
let ty = param_type.ty in
965965
(if i = 0 && splice then
966966
match arg_label with
967-
| Optional _ ->
967+
| Opt _ ->
968968
Location.raise_errorf ~loc
969969
"%@variadic expect the last type to be a non optional"
970-
| Labelled _ | Nolabel -> (
970+
| Lbl _ | Nolbl -> (
971971
if ty.ptyp_desc = Ptyp_any then
972972
Location.raise_errorf ~loc
973973
"%@variadic expect the last type to be an array";
@@ -983,7 +983,7 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
983983
arg_type,
984984
new_arg_types ) =
985985
match arg_label with
986-
| Optional s -> (
986+
| Opt {txt = s} -> (
987987
let arg_type = get_opt_arg_type ~nolabel:false ty in
988988
match arg_type with
989989
| Poly_var _ ->
@@ -993,14 +993,14 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type)
993993
label %s"
994994
s
995995
| _ -> (Arg_optional, arg_type, param_type :: arg_types))
996-
| Labelled _ -> (
996+
| Lbl _ -> (
997997
let arg_type = refine_arg_type ~nolabel:false ty in
998998
( Arg_label,
999999
arg_type,
10001000
match arg_type with
10011001
| Arg_cst _ -> arg_types
10021002
| _ -> param_type :: arg_types ))
1003-
| Nolabel -> (
1003+
| Nolbl -> (
10041004
let arg_type = refine_arg_type ~nolabel:true ty in
10051005
( Arg_empty,
10061006
arg_type,

‎compiler/frontend/ast_typ_uncurry.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -24,12 +24,12 @@
2424

2525
type typ = Parsetree.core_type
2626
type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
27-
type uncurry_type_gen = (Asttypes.arg_label -> typ -> typ -> typ) cxt
27+
type uncurry_type_gen = (Asttypes.arg_label_loc -> typ -> typ -> typ) cxt
2828

2929
module Typ = Ast_helper.Typ
3030

3131
let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
32-
(label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
32+
(label : Asttypes.arg_label_loc) (first_arg : Parsetree.core_type)
3333
(typ : Parsetree.core_type) =
3434
let first_arg = mapper.typ mapper first_arg in
3535
let typ = mapper.typ mapper typ in
@@ -46,7 +46,7 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
4646
| None -> assert false
4747

4848
let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
49-
(label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
49+
(label : Asttypes.arg_label_loc) (first_arg : Parsetree.core_type)
5050
(typ : Parsetree.core_type) =
5151
(* no need to error for optional here,
5252
since we can not make it

‎compiler/frontend/ast_typ_uncurry.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ type typ = Parsetree.core_type
4040
type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
4141

4242
type uncurry_type_gen =
43-
(Asttypes.arg_label ->
43+
(Asttypes.arg_label_loc ->
4444
(* label for error checking *)
4545
typ ->
4646
(* First arg *)

‎compiler/frontend/bs_ast_mapper.ml

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -101,9 +101,8 @@ module T = struct
101101
match desc with
102102
| Ptyp_any -> any ~loc ~attrs ()
103103
| Ptyp_var s -> var ~loc ~attrs s
104-
| Ptyp_arrow {lbl; lbl_loc; arg; ret; arity} ->
105-
arrow ~loc ~attrs ~label_loc:lbl_loc ~arity lbl (sub.typ sub arg)
106-
(sub.typ sub ret)
104+
| Ptyp_arrow {lbl; arg; ret; arity} ->
105+
arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret)
107106
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
108107
| Ptyp_constr (lid, tl) ->
109108
constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)

‎compiler/ml/ast_helper.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -54,8 +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 ?(label_loc = Location.none) ~arity lbl arg ret =
58-
mk ?loc ?attrs (Ptyp_arrow {lbl; lbl_loc = label_loc; arg; ret; arity})
57+
let arrow ?loc ?attrs ~arity lbl arg ret =
58+
mk ?loc ?attrs (Ptyp_arrow {lbl; arg; ret; arity})
5959
let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
6060
let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
6161
let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))

‎compiler/ml/ast_helper.mli

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -57,9 +57,8 @@ module Typ : sig
5757
val arrow :
5858
?loc:loc ->
5959
?attrs:attrs ->
60-
?label_loc:loc ->
6160
arity:arity ->
62-
arg_label ->
61+
arg_label_loc ->
6362
core_type ->
6463
core_type ->
6564
core_type

‎compiler/ml/ast_mapper.ml

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -93,9 +93,8 @@ module T = struct
9393
match desc with
9494
| Ptyp_any -> any ~loc ~attrs ()
9595
| Ptyp_var s -> var ~loc ~attrs s
96-
| Ptyp_arrow {lbl; lbl_loc; arg; ret; arity} ->
97-
arrow ~loc ~attrs ~label_loc:lbl_loc ~arity lbl (sub.typ sub arg)
98-
(sub.typ sub ret)
96+
| Ptyp_arrow {lbl; arg; ret; arity} ->
97+
arrow ~loc ~attrs ~arity lbl (sub.typ sub arg) (sub.typ sub ret)
9998
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
10099
| Ptyp_constr (lid, tl) ->
101100
constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)

‎compiler/ml/ast_mapper_from0.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ module T = struct
9999
| Ptyp_any -> any ~loc ~attrs ()
100100
| Ptyp_var s -> var ~loc ~attrs s
101101
| Ptyp_arrow (lab, t1, t2) ->
102+
let lab = Asttypes.to_arg_label_loc lab in
102103
arrow ~loc ~attrs ~arity:None lab (sub.typ sub t1) (sub.typ sub t2)
103104
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
104105
| Ptyp_constr (lid, tl) -> (

‎compiler/ml/ast_mapper_to0.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ module T = struct
9999
| Ptyp_any -> any ~loc ~attrs ()
100100
| Ptyp_var s -> var ~loc ~attrs s
101101
| Ptyp_arrow {lbl; arg; ret; arity} -> (
102+
let lbl = Asttypes.to_arg_label lbl in
102103
let typ0 = arrow ~loc ~attrs lbl (sub.typ sub arg) (sub.typ sub ret) in
103104
match arity with
104105
| None -> typ0

‎compiler/ml/asttypes.ml

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -91,3 +91,7 @@ let same_arg_label_loc (x : arg_label_loc) y =
9191
match y with
9292
| Opt {txt = s0} -> s = s0
9393
| _ -> false)
94+
95+
let get_lbl_loc = function
96+
| Nolbl -> Location.none
97+
| Lbl {loc} | Opt {loc} -> loc

‎compiler/ml/parsetree.ml

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -77,8 +77,7 @@ and core_type_desc =
7777
| Ptyp_any (* _ *)
7878
| Ptyp_var of string (* 'a *)
7979
| Ptyp_arrow of {
80-
lbl: arg_label;
81-
lbl_loc: Location.t;
80+
lbl: arg_label_loc;
8281
arg: core_type;
8382
ret: core_type;
8483
arity: arity;

‎compiler/ml/pprintast.ml

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -287,9 +287,9 @@ let string_quot f x = pp f "`%s" x
287287

288288
let rec type_with_label ctxt f (label, c) =
289289
match label with
290-
| Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *)
291-
| Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c
292-
| Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c
290+
| Nolbl -> core_type1 ctxt f c (* otherwise parenthesize *)
291+
| Lbl {txt = s} -> pp f "%s:%a" s (core_type1 ctxt) c
292+
| Opt {txt = s} -> pp f "?%s:%a" s (core_type1 ctxt) c
293293

294294
and core_type ctxt f x =
295295
if x.ptyp_attributes <> [] then

‎compiler/ml/printast.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -134,7 +134,7 @@ let rec core_type i ppf x =
134134
| None -> ()
135135
| Some n -> line i ppf "arity = %d\n" n
136136
in
137-
arg_label i ppf lbl;
137+
arg_label_loc i ppf lbl;
138138
core_type i ppf arg;
139139
core_type i ppf ret
140140
| Ptyp_tuple l ->

‎compiler/ml/typecore.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1879,6 +1879,7 @@ and is_nonexpansive_opt = function
18791879
let rec approx_type env sty =
18801880
match sty.ptyp_desc with
18811881
| Ptyp_arrow {lbl = p; ret = sty; arity} ->
1882+
let p = Asttypes.to_arg_label p in
18821883
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
18831884
newty (Tarrow (p, ty1, approx_type env sty, Cok, arity))
18841885
| Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args))

‎compiler/ml/typetexp.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -328,6 +328,7 @@ and transl_type_aux env policy styp =
328328
in
329329
ctyp (Ttyp_var name) ty
330330
| Ptyp_arrow {lbl; arg = st1; ret = st2; arity} ->
331+
let lbl = Asttypes.to_arg_label lbl in
331332
let cty1 = transl_type env policy st1 in
332333
let cty2 = transl_type env policy st2 in
333334
let ty1 = cty1.ctyp_type in

0 commit comments

Comments
 (0)