AST: test storing arity in function type

Author: cristianoc

analysis/src/SignatureHelp.ml

@@ -128,7 +128,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
       | {
        (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *)
        Parsetree.ptyp_desc =
-         Ptyp_arrow (argumentLabel, argumentTypeExpr, nextFunctionExpr);
+         Ptyp_arrow (argumentLabel, argumentTypeExpr, nextFunctionExpr, _);
        ptyp_loc;
       } ->
         let startOffset =

compiler/frontend/ast_compatible.ml

@@ -96,14 +96,14 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
 
 let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
   {
-    ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b);
+    ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b, None);
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }
 
 let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type =
   {
-    ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b);
+    ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b, None);
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }

compiler/frontend/ast_core_type.ml

@@ -108,7 +108,7 @@ let make_obj ~loc xs = Typ.object_ ~loc xs Closed
 *)
 let rec get_uncurry_arity_aux (ty : t) acc =
   match ty.ptyp_desc with
-  | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc)
+  | Ptyp_arrow (_, _, new_ty, _) -> get_uncurry_arity_aux new_ty (succ acc)
   | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc
   | _ -> acc
 
@@ -119,7 +119,7 @@ let rec get_uncurry_arity_aux (ty : t) acc =
 *)
 let get_uncurry_arity (ty : t) =
   match ty.ptyp_desc with
-  | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1)
+  | Ptyp_arrow (_, _, rest, _) -> Some (get_uncurry_arity_aux rest 1)
   | _ -> None
 
 let get_curry_arity (ty : t) =
@@ -139,15 +139,15 @@ type param_type = {
 let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
   Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr; loc} acc ->
       {
-        ptyp_desc = Ptyp_arrow (label, ty, acc);
+        ptyp_desc = Ptyp_arrow (label, ty, acc, None);
         ptyp_loc = loc;
         ptyp_attributes = attr;
       })
 
 let list_of_arrow (ty : t) : t * param_type list =
   let rec aux (ty : t) acc =
     match ty.ptyp_desc with
-    | Ptyp_arrow (label, t1, t2) ->
+    | Ptyp_arrow (label, t1, t2, _) ->
       aux t2
         (({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc}
            : param_type)

compiler/frontend/ast_core_type_class_type.ml

@@ -69,11 +69,11 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
   | {
    ptyp_attributes;
    ptyp_desc =
-     ( Ptyp_arrow (label, args, body)
+     ( Ptyp_arrow (label, args, body, _)
      | Ptyp_constr
          (* function$<...> is re-wrapped around only in case Nothing below *)
          ( {txt = Lident "function$"},
-           [{ptyp_desc = Ptyp_arrow (label, args, body)}; _] ) );
+           [{ptyp_desc = Ptyp_arrow (label, args, body, _)}; _] ) );
    (* let it go without regard label names,
       it will report error later when the label is not empty
    *)

compiler/frontend/bs_ast_mapper.ml

@@ -101,7 +101,7 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow (lab, t1, t2) ->
+    | Ptyp_arrow (lab, t1, t2, _) ->
       arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) ->

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) ->
+  | Ttyp_arrow (Nolabel, core_type1, core_type2, _) ->
     let {dependencies; type_} =
       core_type1 |> fun __x ->
       translateCoreType_ ~config ~type_vars_gen ~type_env __x
@@ -62,8 +62,8 @@ let rec translate_arrow_type ~config ~type_vars_gen
     |> 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)
-    -> (
+  | Ttyp_arrow
+      (((Labelled lbl | Optional lbl) as label), core_type1, core_type2, _) -> (
     let as_label =
       match core_type.ctyp_attributes |> Annotation.get_gentype_as_renaming with
       | Some s -> s

compiler/ml/ast_helper.ml

@@ -54,7 +54,8 @@ module Typ = struct
 
   let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any
   let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a)
-  let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c))
+  let arrow ?loc ?attrs ?arity a b c =
+    mk ?loc ?attrs (Ptyp_arrow (a, b, c, arity))
   let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a)
   let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b))
   let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b))
@@ -81,8 +82,8 @@ module Typ = struct
         | Ptyp_var x ->
           check_variable var_names t.ptyp_loc x;
           Ptyp_var x
-        | Ptyp_arrow (label, core_type, core_type') ->
-          Ptyp_arrow (label, loop core_type, loop core_type')
+        | Ptyp_arrow (label, core_type, core_type', a) ->
+          Ptyp_arrow (label, loop core_type, loop core_type', a)
         | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
         | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names
           ->

compiler/ml/ast_helper.mli

@@ -55,7 +55,13 @@ module Typ : sig
   val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type
   val var : ?loc:loc -> ?attrs:attrs -> string -> core_type
   val arrow :
-    ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> core_type
+    ?loc:loc ->
+    ?attrs:attrs ->
+    ?arity:int ->
+    arg_label ->
+    core_type ->
+    core_type ->
+    core_type
   val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type
   val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type
   val object_ :

compiler/ml/ast_iterator.ml

@@ -96,7 +96,7 @@ module T = struct
     sub.attributes sub attrs;
     match desc with
     | Ptyp_any | Ptyp_var _ -> ()
-    | Ptyp_arrow (_lab, t1, t2) ->
+    | Ptyp_arrow (_lab, t1, t2, _) ->
       sub.typ sub t1;
       sub.typ sub t2
     | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl

compiler/ml/ast_mapper.ml

@@ -93,7 +93,7 @@ module T = struct
     match desc with
     | Ptyp_any -> any ~loc ~attrs ()
     | Ptyp_var s -> var ~loc ~attrs s
-    | Ptyp_arrow (lab, t1, t2) ->
+    | Ptyp_arrow (lab, t1, t2, _) ->
       arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2)
     | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl)
     | Ptyp_constr (lid, tl) ->