Skip to content

Commit 6130881

Browse files
cristianoccristianoc
committed
Refactor: construct every Ptyp_arrow via Ast_helper.Typ.arrow.
This should give an explicit handle over how all arrow types are constructed.
1 parent f26d5c9 commit 6130881

13 files changed

+93
-172
lines changed

‎compiler/frontend/ast_comb.ml‎

Lines changed: 0 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -33,30 +33,6 @@ open Ast_helper
3333
[Exp.constraint_ ~loc e
3434
(Ast_literal.type_unit ~loc ())] *)
3535

36-
let tuple_type_pair ?loc kind arity =
37-
let prefix = "a" in
38-
if arity = 0 then
39-
let ty = Typ.var ?loc (prefix ^ "0") in
40-
match kind with
41-
| `Run -> (ty, [], ty)
42-
| `Make ->
43-
( Ast_compatible.arrow ?loc ~arity:None (Ast_literal.type_unit ?loc ()) ty,
44-
[],
45-
ty )
46-
else
47-
let number = arity + 1 in
48-
let tys =
49-
Ext_list.init number (fun i ->
50-
Typ.var ?loc (prefix ^ string_of_int (number - i - 1)))
51-
in
52-
match tys with
53-
| result :: rest ->
54-
( Ext_list.reduce_from_left tys (fun r arg ->
55-
Ast_compatible.arrow ?loc ~arity:None arg r),
56-
List.rev rest,
57-
result )
58-
| [] -> assert false
59-
6036
let regexp_id = Ast_literal.Lid.regexp_id
6137

6238
let to_regexp_type loc = Typ.constr ~loc {txt = regexp_id; loc} []

‎compiler/frontend/ast_comb.mli‎

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -31,12 +31,6 @@
3131
(* val discard_exp_as_unit :
3232
Location.t -> Parsetree.expression -> Parsetree.expression *)
3333

34-
val tuple_type_pair :
35-
?loc:Ast_helper.loc ->
36-
[< `Make | `Run] ->
37-
int ->
38-
Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type
39-
4034
val to_undefined_type : Location.t -> Parsetree.core_type -> Parsetree.core_type
4135

4236
val to_regexp_type : Location.t -> Parsetree.core_type

‎compiler/frontend/ast_compatible.ml‎

Lines changed: 0 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -30,9 +30,6 @@ open Parsetree
3030

3131
let default_loc = Location.none
3232

33-
let arrow ?loc ?attrs ~arity typ ret =
34-
Ast_helper.Typ.arrow ?loc ?attrs ~arity {lbl = Nolabel; typ} ret
35-
3633
let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
3734
(args : expression list) : expression =
3835
{
@@ -138,34 +135,6 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
138135
};
139136
}
140137

141-
let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret :
142-
core_type =
143-
{
144-
ptyp_desc =
145-
Ptyp_arrow
146-
{
147-
arg = {lbl = Asttypes.Labelled {txt; loc = default_loc}; typ};
148-
ret;
149-
arity;
150-
};
151-
ptyp_loc = loc;
152-
ptyp_attributes = attrs;
153-
}
154-
155-
let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret : core_type
156-
=
157-
{
158-
ptyp_desc =
159-
Ptyp_arrow
160-
{
161-
arg = {lbl = Asttypes.Optional {txt; loc = default_loc}; typ};
162-
ret;
163-
arity;
164-
};
165-
ptyp_loc = loc;
166-
ptyp_attributes = attrs;
167-
}
168-
169138
let rec_type_str ?(loc = default_loc) rf tds : structure_item =
170139
{pstr_loc = loc; pstr_desc = Pstr_type (rf, tds)}
171140

‎compiler/frontend/ast_compatible.mli‎

Lines changed: 0 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -90,32 +90,6 @@ val fun_ :
9090
expression ->
9191
expression *)
9292

93-
val arrow :
94-
?loc:Location.t ->
95-
?attrs:attrs ->
96-
arity:Asttypes.arity ->
97-
core_type ->
98-
core_type ->
99-
core_type
100-
101-
val label_arrow :
102-
?loc:Location.t ->
103-
?attrs:attrs ->
104-
arity:Asttypes.arity ->
105-
string ->
106-
core_type ->
107-
core_type ->
108-
core_type
109-
110-
val opt_arrow :
111-
?loc:Location.t ->
112-
?attrs:attrs ->
113-
arity:Asttypes.arity ->
114-
string ->
115-
core_type ->
116-
core_type ->
117-
core_type
118-
11993
(* val nonrec_type_str:
12094
?loc:loc ->
12195
type_declaration list ->

‎compiler/frontend/ast_core_type.ml‎

Lines changed: 5 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -95,8 +95,9 @@ 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 ~arity:(Some arity) label.txt
99-
tyvar acc)
98+
Ast_helper.Typ.arrow ~loc:label.loc ~arity:(Some arity)
99+
{lbl = Asttypes.Labelled label; typ = tyvar}
100+
acc)
100101

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

@@ -141,12 +142,8 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
141142
let t =
142143
Ext_list.fold_right new_arg_types_ty result
143144
(fun {label; ty; attr; loc} acc ->
144-
{
145-
ptyp_desc =
146-
Ptyp_arrow {arg = {lbl = label; typ = ty}; ret = acc; arity = None};
147-
ptyp_loc = loc;
148-
ptyp_attributes = attr;
149-
})
145+
Ast_helper.Typ.arrow ~loc ~attrs:attr ~arity:None
146+
{lbl = label; typ = ty} acc)
150147
in
151148
match t.ptyp_desc with
152149
| Ptyp_arrow arr ->

‎compiler/frontend/ast_derive_abstract.ml‎

Lines changed: 16 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -83,7 +83,8 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
8383
Ext_list.fold_right label_declarations
8484
( [],
8585
(if has_optional_field then
86-
Ast_compatible.arrow ~loc ~arity:None (Ast_literal.type_unit ())
86+
Ast_helper.Typ.arrow ~loc ~arity:None
87+
{lbl = Nolabel; typ = Ast_literal.type_unit ()}
8788
core_type
8889
else core_type),
8990
[] )
@@ -114,18 +115,21 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
114115
in
115116
if is_optional then
116117
let optional_type = Ast_core_type.lift_option_type pld_type in
117-
( Ast_compatible.opt_arrow ~loc:pld_loc ~arity label_name pld_type
118+
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
119+
{lbl = Asttypes.Optional pld_name; typ = pld_type}
118120
maker,
119121
Val.mk ~loc:pld_loc
120122
(if light then pld_name
121123
else {pld_name with txt = pld_name.txt ^ "Get"})
122124
~attrs:get_optional_attrs ~prim
123-
(Ast_compatible.arrow ~loc ~arity:(Some 1) core_type
125+
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
126+
{lbl = Nolabel; typ = core_type}
124127
optional_type)
125128
:: acc )
126129
else
127-
( Ast_compatible.label_arrow ~loc:pld_loc ~arity label_name
128-
pld_type maker,
130+
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
131+
{lbl = Asttypes.Labelled pld_name; typ = pld_type}
132+
maker,
129133
Val.mk ~loc:pld_loc
130134
(if light then pld_name
131135
else {pld_name with txt = pld_name.txt ^ "Get"})
@@ -135,15 +139,19 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
135139
External_ffi_types.ffi_bs_as_prims
136140
[External_arg_spec.dummy] Return_identity
137141
(Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
138-
(Ast_compatible.arrow ~loc ~arity:(Some 1) core_type pld_type)
142+
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
143+
{lbl = Nolabel; typ = core_type}
144+
pld_type)
139145
:: acc )
140146
in
141147
let is_current_field_mutable = pld_mutable = Mutable in
142148
let acc =
143149
if is_current_field_mutable then
144150
let setter_type =
145-
Ast_compatible.arrow ~arity:(Some 2) core_type
146-
(Ast_compatible.arrow ~arity:None pld_type (* setter *)
151+
Ast_helper.Typ.arrow ~arity:(Some 2)
152+
{lbl = Nolabel; typ = core_type}
153+
(Ast_helper.Typ.arrow ~arity:None
154+
{lbl = Nolabel; typ = pld_type} (* setter *)
147155
(Ast_literal.type_unit ()))
148156
in
149157
Val.mk ~loc:pld_loc

‎compiler/frontend/ast_derive_js_mapper.ml‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ let erase_type_str =
6969
Str.primitive
7070
(Val.mk ~prim:["%identity"]
7171
{loc = noloc; txt = erase_type_lit}
72-
(Ast_compatible.arrow ~arity:(Some 1) any any))
72+
(Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = any} any))
7373

7474
let unsafe_index = "_index"
7575

@@ -79,8 +79,8 @@ let unsafe_index_get =
7979
(Val.mk ~prim:[""]
8080
{loc = noloc; txt = unsafe_index}
8181
~attrs:[Ast_attributes.get_index]
82-
(Ast_compatible.arrow ~arity:None any
83-
(Ast_compatible.arrow ~arity:None any any)))
82+
(Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any}
83+
(Ast_helper.Typ.arrow ~arity:None {lbl = Nolabel; typ = any} any)))
8484

8585
let unsafe_index_get_exp = Exp.ident {loc = noloc; txt = Lident unsafe_index}
8686

@@ -131,7 +131,8 @@ let app1 = Ast_compatible.app1
131131

132132
let app2 = Ast_compatible.app2
133133

134-
let ( ->~ ) a b = Ast_compatible.arrow ~arity:(Some 1) a b
134+
let ( ->~ ) a b =
135+
Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = a} b
135136

136137
let raise_when_not_found_ident =
137138
Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
@@ -303,7 +304,9 @@ let init () =
303304
let pat_from_js = {Asttypes.loc; txt = from_js} in
304305
let to_js_type result =
305306
Ast_comb.single_non_rec_val pat_to_js
306-
(Ast_compatible.arrow ~arity:(Some 1) core_type result)
307+
(Ast_helper.Typ.arrow ~arity:(Some 1)
308+
{lbl = Nolabel; typ = core_type}
309+
result)
307310
in
308311
let new_type, new_tdcl =
309312
U.new_type_of_type_declaration tdcl ("abs_" ^ name)

‎compiler/frontend/ast_derive_projector.ml‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -136,7 +136,8 @@ let init () =
136136
| Ptype_record label_declarations ->
137137
Ext_list.map label_declarations (fun {pld_name; pld_type} ->
138138
Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
139-
(Ast_compatible.arrow ~arity:(Some 1) core_type
139+
(Ast_helper.Typ.arrow ~arity:(Some 1)
140+
{lbl = Nolabel; typ = core_type}
140141
pld_type
141142
(*arity will alwys be 1 since these are single param functions*)))
142143
| Ptype_variant constructor_declarations ->
@@ -168,7 +169,8 @@ let init () =
168169
Ast_comb.single_non_rec_val ?attrs:gentype_attrs
169170
{loc; txt = Ext_string.uncapitalize_ascii con_name}
170171
(Ext_list.fold_right pcd_args annotate_type (fun x acc ->
171-
Ast_compatible.arrow ~arity:None x acc)
172+
Ast_helper.Typ.arrow ~arity:None
173+
{lbl = Nolabel; typ = x} acc)
172174
|> add_arity ~arity))
173175
| Ptype_open | Ptype_abstract ->
174176
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;

‎compiler/frontend/ast_exp_handle_external.ml‎

Lines changed: 20 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -22,8 +22,6 @@
2222
* along with this program; if not, write to the Free Software
2323
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
2424

25-
open Ast_helper
26-
2725
(**
2826
{[
2927
Js.undefinedToOption
@@ -44,25 +42,26 @@ let handle_external loc (x : string) : Parsetree.expression =
4442
pexp_desc =
4543
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
4644
~pval_type:
47-
(Typ.arrow ~arity:(Some 1)
48-
{lbl = Nolabel; typ = Typ.any ()}
49-
(Typ.any ()))
45+
(Ast_helper.Typ.arrow ~arity:(Some 1)
46+
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
47+
(Ast_helper.Typ.any ()))
5048
[str_exp];
5149
}
5250
in
5351
let empty =
5452
(* FIXME: the empty delimiter does not make sense*)
55-
Exp.ident ~loc {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
53+
Ast_helper.Exp.ident ~loc
54+
{txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
5655
in
5756
let undefined_typeof =
58-
Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
57+
Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
5958
in
60-
let typeof = Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in
59+
let typeof = Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in
6160

6261
Ast_compatible.app1 ~loc undefined_typeof
63-
(Exp.ifthenelse ~loc
62+
(Ast_helper.Exp.ifthenelse ~loc
6463
(Ast_compatible.app2 ~loc
65-
(Exp.ident ~loc {loc; txt = Lident "=="})
64+
(Ast_helper.Exp.ident ~loc {loc; txt = Lident "=="})
6665
(Ast_compatible.app1 ~loc typeof raw_exp)
6766
(Ast_compatible.const_exp_string ~loc "undefined"))
6867
empty (Some raw_exp))
@@ -72,8 +71,8 @@ let handle_debugger loc (payload : Ast_payload.t) =
7271
| PStr [] ->
7372
Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
7473
~pval_type:
75-
(Typ.arrow ~arity:(Some 1)
76-
{lbl = Nolabel; typ = Typ.any ()}
74+
(Ast_helper.Typ.arrow ~arity:(Some 1)
75+
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
7776
(Ast_literal.type_unit ()))
7877
[Ast_literal.val_unit ~loc ()]
7978
| _ ->
@@ -99,9 +98,9 @@ let handle_raw ~kind loc payload =
9998
pexp_desc =
10099
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
101100
~pval_type:
102-
(Typ.arrow ~arity:(Some 1)
103-
{lbl = Nolabel; typ = Typ.any ()}
104-
(Typ.any ()))
101+
(Ast_helper.Typ.arrow ~arity:(Some 1)
102+
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
103+
(Ast_helper.Typ.any ()))
105104
[exp];
106105
pexp_attributes =
107106
(match !is_function with
@@ -152,9 +151,9 @@ let handle_ffi ~loc ~payload =
152151
pexp_desc =
153152
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
154153
~pval_type:
155-
(Typ.arrow ~arity:(Some 1)
156-
{lbl = Nolabel; typ = Typ.any ()}
157-
(Typ.any ()))
154+
(Ast_helper.Typ.arrow ~arity:(Some 1)
155+
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
156+
(Ast_helper.Typ.any ()))
158157
[exp];
159158
pexp_attributes =
160159
(match !is_function with
@@ -171,9 +170,9 @@ let handle_raw_structure loc payload =
171170
pexp_desc =
172171
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
173172
~pval_type:
174-
(Typ.arrow ~arity:(Some 1)
175-
{lbl = Nolabel; typ = Typ.any ()}
176-
(Typ.any ()))
173+
(Ast_helper.Typ.arrow ~arity:(Some 1)
174+
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
175+
(Ast_helper.Typ.any ()))
177176
[exp];
178177
}
179178
| None ->

‎compiler/frontend/ast_typ_uncurry.ml‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -26,20 +26,18 @@ type typ = Parsetree.core_type
2626
type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a
2727
type uncurry_type_gen = (Asttypes.arg_label -> typ -> typ -> typ) cxt
2828

29-
module Typ = Ast_helper.Typ
30-
3129
let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
3230
(label : Asttypes.arg_label) (first_arg : Parsetree.core_type)
3331
(typ : Parsetree.core_type) =
3432
let first_arg = mapper.typ mapper first_arg in
3533
let typ = mapper.typ mapper typ in
3634
let meth_type =
37-
Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
35+
Ast_helper.Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
3836
in
3937
let arity = Ast_core_type.get_uncurry_arity meth_type in
4038
match arity with
4139
| Some n ->
42-
Typ.constr
40+
Ast_helper.Typ.constr
4341
{
4442
txt = Ldot (Ast_literal.Lid.js_meth_callback, "arity" ^ string_of_int n);
4543
loc;
@@ -59,7 +57,9 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
5957
let first_arg = mapper.typ mapper first_arg in
6058
let typ = mapper.typ mapper typ in
6159

62-
let fn_type = Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ in
60+
let fn_type =
61+
Ast_helper.Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
62+
in
6363
let arity = Ast_core_type.get_uncurry_arity fn_type in
6464
let fn_type =
6565
match fn_type.ptyp_desc with

0 commit comments

Comments
 (0)