Skip to content

Refactor: construct every Ptyp_arrow via Ast_helper.Typ.arrow. #7647

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Jul 17, 2025
Merged

Refactor: construct every Ptyp_arrow via Ast_helper.Typ.arrow. #7647

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
6130881
Refactor: construct every Ptyp_arrow via Ast_helper.Typ.arrow.
cristianoc Jul 15, 2025
2317a82
Begin adding an arrow construction to Ast_helper that takes a list of…
cristianoc Jul 16, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
24 changes: 0 additions & 24 deletions compiler/frontend/ast_comb.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -33,30 +33,6 @@ open Ast_helper
[Exp.constraint_ ~loc e
(Ast_literal.type_unit ~loc ())] *)

let tuple_type_pair ?loc kind arity =
let prefix = "a" in
if arity = 0 then
let ty = Typ.var ?loc (prefix ^ "0") in
match kind with
| `Run -> (ty, [], ty)
| `Make ->
( Ast_compatible.arrow ?loc ~arity:None (Ast_literal.type_unit ?loc ()) ty,
[],
ty )
else
let number = arity + 1 in
let tys =
Ext_list.init number (fun i ->
Typ.var ?loc (prefix ^ string_of_int (number - i - 1)))
in
match tys with
| result :: rest ->
( Ext_list.reduce_from_left tys (fun r arg ->
Ast_compatible.arrow ?loc ~arity:None arg r),
List.rev rest,
result )
| [] -> assert false

let regexp_id = Ast_literal.Lid.regexp_id

let to_regexp_type loc = Typ.constr ~loc {txt = regexp_id; loc} []
Expand Down
6 changes: 0 additions & 6 deletions compiler/frontend/ast_comb.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,12 +31,6 @@
(* val discard_exp_as_unit :
Location.t -> Parsetree.expression -> Parsetree.expression *)

val tuple_type_pair :
?loc:Ast_helper.loc ->
[< `Make | `Run] ->
int ->
Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type

val to_undefined_type : Location.t -> Parsetree.core_type -> Parsetree.core_type

val to_regexp_type : Location.t -> Parsetree.core_type
Expand Down
31 changes: 0 additions & 31 deletions compiler/frontend/ast_compatible.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,9 +30,6 @@ open Parsetree

let default_loc = Location.none

let arrow ?loc ?attrs ~arity typ ret =
Ast_helper.Typ.arrow ?loc ?attrs ~arity {lbl = Nolabel; typ} ret

let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression)
(args : expression list) : expression =
{
Expand Down Expand Up @@ -138,34 +135,6 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
};
}

let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret :
core_type =
{
ptyp_desc =
Ptyp_arrow
{
arg = {lbl = Asttypes.Labelled {txt; loc = default_loc}; typ};
ret;
arity;
};
ptyp_loc = loc;
ptyp_attributes = attrs;
}

let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret : core_type
=
{
ptyp_desc =
Ptyp_arrow
{
arg = {lbl = Asttypes.Optional {txt; loc = default_loc}; typ};
ret;
arity;
};
ptyp_loc = loc;
ptyp_attributes = attrs;
}

let rec_type_str ?(loc = default_loc) rf tds : structure_item =
{pstr_loc = loc; pstr_desc = Pstr_type (rf, tds)}

Expand Down
26 changes: 0 additions & 26 deletions compiler/frontend/ast_compatible.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -90,32 +90,6 @@ val fun_ :
expression ->
expression *)

val arrow :
?loc:Location.t ->
?attrs:attrs ->
arity:Asttypes.arity ->
core_type ->
core_type ->
core_type

val label_arrow :
?loc:Location.t ->
?attrs:attrs ->
arity:Asttypes.arity ->
string ->
core_type ->
core_type ->
core_type

val opt_arrow :
?loc:Location.t ->
?attrs:attrs ->
arity:Asttypes.arity ->
string ->
core_type ->
core_type ->
core_type

(* val nonrec_type_str:
?loc:loc ->
type_declaration list ->
Expand Down
17 changes: 7 additions & 10 deletions compiler/frontend/ast_core_type.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -93,10 +93,11 @@ let from_labels ~loc arity labels : t =
(Ext_list.map2 labels tyvars (fun x y -> Parsetree.Otag (x, [], y)))
Closed
in
Ext_list.fold_right2 labels tyvars result_type
(fun label (* {loc ; txt = label }*) tyvar acc ->
Ast_compatible.label_arrow ~loc:label.loc ~arity:(Some arity) label.txt
tyvar acc)
let args =
Ext_list.map2 labels tyvars (fun label tyvar ->
{Parsetree.lbl = Asttypes.Labelled label; typ = tyvar})
in
Typ.arrows ~loc args result_type

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

Expand Down Expand Up @@ -141,12 +142,8 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
let t =
Ext_list.fold_right new_arg_types_ty result
(fun {label; ty; attr; loc} acc ->
{
ptyp_desc =
Ptyp_arrow {arg = {lbl = label; typ = ty}; ret = acc; arity = None};
ptyp_loc = loc;
ptyp_attributes = attr;
})
Ast_helper.Typ.arrow ~loc ~attrs:attr ~arity:None
{lbl = label; typ = ty} acc)
in
match t.ptyp_desc with
| Ptyp_arrow arr ->
Expand Down
24 changes: 16 additions & 8 deletions compiler/frontend/ast_derive_abstract.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -83,7 +83,8 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
Ext_list.fold_right label_declarations
( [],
(if has_optional_field then
Ast_compatible.arrow ~loc ~arity:None (Ast_literal.type_unit ())
Ast_helper.Typ.arrow ~loc ~arity:None
{lbl = Nolabel; typ = Ast_literal.type_unit ()}
core_type
else core_type),
[] )
Expand Down Expand Up @@ -114,18 +115,21 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
in
if is_optional then
let optional_type = Ast_core_type.lift_option_type pld_type in
( Ast_compatible.opt_arrow ~loc:pld_loc ~arity label_name pld_type
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
{lbl = Asttypes.Optional pld_name; typ = pld_type}
maker,
Val.mk ~loc:pld_loc
(if light then pld_name
else {pld_name with txt = pld_name.txt ^ "Get"})
~attrs:get_optional_attrs ~prim
(Ast_compatible.arrow ~loc ~arity:(Some 1) core_type
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
{lbl = Nolabel; typ = core_type}
optional_type)
:: acc )
else
( Ast_compatible.label_arrow ~loc:pld_loc ~arity label_name
pld_type maker,
( Ast_helper.Typ.arrow ~loc:pld_loc ~arity
{lbl = Asttypes.Labelled pld_name; typ = pld_type}
maker,
Val.mk ~loc:pld_loc
(if light then pld_name
else {pld_name with txt = pld_name.txt ^ "Get"})
Expand All @@ -135,15 +139,19 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) :
External_ffi_types.ffi_bs_as_prims
[External_arg_spec.dummy] Return_identity
(Js_get {js_get_name = prim_as_name; js_get_scopes = []}))
(Ast_compatible.arrow ~loc ~arity:(Some 1) core_type pld_type)
(Ast_helper.Typ.arrow ~loc ~arity:(Some 1)
{lbl = Nolabel; typ = core_type}
pld_type)
:: acc )
in
let is_current_field_mutable = pld_mutable = Mutable in
let acc =
if is_current_field_mutable then
let setter_type =
Ast_compatible.arrow ~arity:(Some 2) core_type
(Ast_compatible.arrow ~arity:None pld_type (* setter *)
Ast_helper.Typ.arrow ~arity:(Some 2)
{lbl = Nolabel; typ = core_type}
(Ast_helper.Typ.arrow ~arity:None
{lbl = Nolabel; typ = pld_type} (* setter *)
(Ast_literal.type_unit ()))
in
Val.mk ~loc:pld_loc
Expand Down
13 changes: 8 additions & 5 deletions compiler/frontend/ast_derive_js_mapper.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -69,7 +69,7 @@ let erase_type_str =
Str.primitive
(Val.mk ~prim:["%identity"]
{loc = noloc; txt = erase_type_lit}
(Ast_compatible.arrow ~arity:(Some 1) any any))
(Ast_helper.Typ.arrow ~arity:(Some 1) {lbl = Nolabel; typ = any} any))

let unsafe_index = "_index"

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

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

Expand Down Expand Up @@ -131,7 +131,8 @@ let app1 = Ast_compatible.app1

let app2 = Ast_compatible.app2

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

let raise_when_not_found_ident =
Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound")
Expand Down Expand Up @@ -303,7 +304,9 @@ let init () =
let pat_from_js = {Asttypes.loc; txt = from_js} in
let to_js_type result =
Ast_comb.single_non_rec_val pat_to_js
(Ast_compatible.arrow ~arity:(Some 1) core_type result)
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = core_type}
result)
in
let new_type, new_tdcl =
U.new_type_of_type_declaration tdcl ("abs_" ^ name)
Expand Down
6 changes: 4 additions & 2 deletions compiler/frontend/ast_derive_projector.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -136,7 +136,8 @@ let init () =
| Ptype_record label_declarations ->
Ext_list.map label_declarations (fun {pld_name; pld_type} ->
Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name
(Ast_compatible.arrow ~arity:(Some 1) core_type
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = core_type}
pld_type
(*arity will alwys be 1 since these are single param functions*)))
| Ptype_variant constructor_declarations ->
Expand Down Expand Up @@ -168,7 +169,8 @@ let init () =
Ast_comb.single_non_rec_val ?attrs:gentype_attrs
{loc; txt = Ext_string.uncapitalize_ascii con_name}
(Ext_list.fold_right pcd_args annotate_type (fun x acc ->
Ast_compatible.arrow ~arity:None x acc)
Ast_helper.Typ.arrow ~arity:None
{lbl = Nolabel; typ = x} acc)
|> add_arity ~arity))
| Ptype_open | Ptype_abstract ->
Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name;
Expand Down
41 changes: 20 additions & 21 deletions compiler/frontend/ast_exp_handle_external.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,8 +22,6 @@
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

open Ast_helper

(**
{[
Js.undefinedToOption
Expand All @@ -44,25 +42,26 @@ let handle_external loc (x : string) : Parsetree.expression =
pexp_desc =
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
~pval_type:
(Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Typ.any ()}
(Typ.any ()))
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
(Ast_helper.Typ.any ()))
[str_exp];
}
in
let empty =
(* FIXME: the empty delimiter does not make sense*)
Exp.ident ~loc {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
Ast_helper.Exp.ident ~loc
{txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc}
in
let undefined_typeof =
Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")}
in
let typeof = Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in
let typeof = Ast_helper.Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in

Ast_compatible.app1 ~loc undefined_typeof
(Exp.ifthenelse ~loc
(Ast_helper.Exp.ifthenelse ~loc
(Ast_compatible.app2 ~loc
(Exp.ident ~loc {loc; txt = Lident "=="})
(Ast_helper.Exp.ident ~loc {loc; txt = Lident "=="})
(Ast_compatible.app1 ~loc typeof raw_exp)
(Ast_compatible.const_exp_string ~loc "undefined"))
empty (Some raw_exp))
Expand All @@ -72,8 +71,8 @@ let handle_debugger loc (payload : Ast_payload.t) =
| PStr [] ->
Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"]
~pval_type:
(Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Typ.any ()}
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
(Ast_literal.type_unit ()))
[Ast_literal.val_unit ~loc ()]
| _ ->
Expand All @@ -99,9 +98,9 @@ let handle_raw ~kind loc payload =
pexp_desc =
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
~pval_type:
(Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Typ.any ()}
(Typ.any ()))
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
(Ast_helper.Typ.any ()))
[exp];
pexp_attributes =
(match !is_function with
Expand Down Expand Up @@ -152,9 +151,9 @@ let handle_ffi ~loc ~payload =
pexp_desc =
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"]
~pval_type:
(Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Typ.any ()}
(Typ.any ()))
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
(Ast_helper.Typ.any ()))
[exp];
pexp_attributes =
(match !is_function with
Expand All @@ -171,9 +170,9 @@ let handle_raw_structure loc payload =
pexp_desc =
Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"]
~pval_type:
(Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Typ.any ()}
(Typ.any ()))
(Ast_helper.Typ.arrow ~arity:(Some 1)
{lbl = Nolabel; typ = Ast_helper.Typ.any ()}
(Ast_helper.Typ.any ()))
[exp];
}
| None ->
Expand Down
Loading
Loading