Also adapt arrow in typedtree.

Author: cristianoc

compiler/gentype/TranslateCoreType.ml

@@ -52,7 +52,7 @@ let rec translate_arrow_type ~config ~type_vars_gen
     ~no_function_return_dependencies ~type_env ~rev_arg_deps ~rev_args
     (core_type : Typedtree.core_type) =
   match core_type.ctyp_desc with
-  | Ttyp_arrow (Nolabel, core_type1, core_type2, arity)
+  | Ttyp_arrow ({lbl = Nolabel; typ = core_type1}, core_type2, arity)
     when arity = None || rev_args = [] ->
     let {dependencies; type_} =
       core_type1 |> fun __x ->
@@ -64,7 +64,9 @@ let rec translate_arrow_type ~config ~type_vars_gen
          ~no_function_return_dependencies ~type_env ~rev_arg_deps:next_rev_deps
          ~rev_args:((Nolabel, type_) :: rev_args)
   | Ttyp_arrow
-      (((Labelled lbl | Optional lbl) as label), core_type1, core_type2, arity)
+      ( {lbl = (Labelled lbl | Optional lbl) as label; typ = core_type1},
+        core_type2,
+        arity )
     when arity = None || rev_args = [] -> (
     let as_label =
       match core_type.ctyp_attributes |> Annotation.get_gentype_as_renaming with

compiler/ml/printtyped.ml

@@ -149,11 +149,11 @@ let rec core_type i ppf x =
   match x.ctyp_desc with
   | Ttyp_any -> line i ppf "Ttyp_any\n"
   | Ttyp_var s -> line i ppf "Ttyp_var %s\n" s
-  | Ttyp_arrow (l, ct1, ct2, _) ->
+  | Ttyp_arrow (arg, ret, _) ->
     line i ppf "Ttyp_arrow\n";
-    arg_label i ppf l;
-    core_type i ppf ct1;
-    core_type i ppf ct2
+    arg_label i ppf arg.lbl;
+    core_type i ppf arg.typ;
+    core_type i ppf ret
   | Ttyp_tuple l ->
     line i ppf "Ttyp_tuple\n";
     list i core_type ppf l

compiler/ml/tast_iterator.ml

@@ -284,9 +284,9 @@ let typ sub {ctyp_desc; ctyp_env; _} =
   match ctyp_desc with
   | Ttyp_any -> ()
   | Ttyp_var _ -> ()
-  | Ttyp_arrow (_, ct1, ct2, _) ->
-    sub.typ sub ct1;
-    sub.typ sub ct2
+  | Ttyp_arrow (arg, ret, _) ->
+    sub.typ sub arg.typ;
+    sub.typ sub ret
   | Ttyp_tuple list -> List.iter (sub.typ sub) list
   | Ttyp_constr (_, _, list) -> List.iter (sub.typ sub) list
   | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list

compiler/ml/tast_mapper.ml

@@ -359,8 +359,8 @@ let typ sub x =
   let ctyp_desc =
     match x.ctyp_desc with
     | (Ttyp_any | Ttyp_var _) as d -> d
-    | Ttyp_arrow (label, ct1, ct2, arity) ->
-      Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2, arity)
+    | Ttyp_arrow (arg, ret, arity) ->
+      Ttyp_arrow ({arg with typ = sub.typ sub arg.typ}, sub.typ sub ret, arity)
     | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list)
     | Ttyp_constr (path, lid, list) ->
       Ttyp_constr (path, lid, List.map (sub.typ sub) list)

compiler/ml/typedtree.ml

@@ -303,10 +303,12 @@ and core_type = {
   ctyp_attributes: attribute list;
 }
 
+and arg = {lbl: Noloc.arg_label; typ: core_type}
+
 and core_type_desc =
   | Ttyp_any
   | Ttyp_var of string
-  | Ttyp_arrow of Noloc.arg_label * core_type * core_type * arity
+  | Ttyp_arrow of arg * core_type * arity
   | Ttyp_tuple of core_type list
   | Ttyp_constr of Path.t * Longident.t loc * core_type list
   | Ttyp_object of object_field list * closed_flag

compiler/ml/typedtree.mli

@@ -409,10 +409,12 @@ and core_type = {
   ctyp_attributes: attributes;
 }
 
+and arg = {lbl: Noloc.arg_label; typ: core_type}
+
 and core_type_desc =
   | Ttyp_any
   | Ttyp_var of string
-  | Ttyp_arrow of Noloc.arg_label * core_type * core_type * arity
+  | Ttyp_arrow of arg * core_type * arity
   | Ttyp_tuple of core_type list
   | Ttyp_constr of Path.t * Longident.t loc * core_type list
   | Ttyp_object of object_field list * closed_flag

compiler/ml/typedtreeIter.ml

@@ -375,9 +375,9 @@ end = struct
     (match ct.ctyp_desc with
     | Ttyp_any -> ()
     | Ttyp_var _ -> ()
-    | Ttyp_arrow (_label, ct1, ct2, _) ->
-      iter_core_type ct1;
-      iter_core_type ct2
+    | Ttyp_arrow (arg, ret, _) ->
+      iter_core_type arg.typ;
+      iter_core_type ret
     | Ttyp_tuple list -> List.iter iter_core_type list
     | Ttyp_constr (_path, _, list) -> List.iter iter_core_type list
     | Ttyp_object (list, _o) -> List.iter iter_object_field list

compiler/ml/typetexp.ml

@@ -329,7 +329,7 @@ and transl_type_aux env policy styp =
       else ty1
     in
     let ty = newty (Tarrow (lbl, ty1, cty2.ctyp_type, Cok, arity)) in
-    ctyp (Ttyp_arrow (lbl, cty1, cty2, arity)) ty
+    ctyp (Ttyp_arrow ({lbl; typ = cty1}, cty2, arity)) ty
   | Ptyp_tuple stl ->
     assert (List.length stl >= 2);
     let ctys = List.map (transl_type env policy) stl in