Refactor parse tree for function arguments.

analysis/reanalyze/src/DeadOptionalArgs.ml

@@ -31,17 +31,17 @@ let addFunctionReference ~(locFrom : Location.t) ~(locTo : Location.t) =
 let rec hasOptionalArgs (texpr : Types.type_expr) =
   match texpr.desc with
   | _ when not (active ()) -> false
-  | Tarrow (Optional _, _tFrom, _tTo, _, _) -> true
-  | Tarrow (_, _tFrom, tTo, _, _) -> hasOptionalArgs tTo
+  | Tarrow ({lbl = Optional _}, _tTo, _, _) -> true
+  | Tarrow (_, tTo, _, _) -> hasOptionalArgs tTo
   | Tlink t -> hasOptionalArgs t
   | Tsubst t -> hasOptionalArgs t
   | _ -> false
 
 let rec fromTypeExpr (texpr : Types.type_expr) =
   match texpr.desc with
   | _ when not (active ()) -> []
-  | Tarrow (Optional s, _tFrom, tTo, _, _) -> s :: fromTypeExpr tTo
-  | Tarrow (_, _tFrom, tTo, _, _) -> fromTypeExpr tTo
+  | Tarrow ({lbl = Optional s}, tTo, _, _) -> s :: fromTypeExpr tTo
+  | Tarrow (_, tTo, _, _) -> fromTypeExpr tTo
   | Tlink t -> fromTypeExpr t
   | Tsubst t -> fromTypeExpr t
   | _ -> []

analysis/src/CompletionBackEnd.ml

@@ -978,7 +978,10 @@ and getCompletionsForContextPath ~debug ~full ~opens ~rawOpens ~pos ~env ~exact
         | [] -> tRet
         | (label, tArg) :: rest ->
           let restType = reconstructFunctionType rest tRet in
-          {typ with desc = Tarrow (label, tArg, restType, Cok, None)}
+          {
+            typ with
+            desc = Tarrow ({lbl = label; typ = tArg}, restType, Cok, None);
+          }
       in
       let rec processApply args labels =
         match (args, labels) with

analysis/src/CompletionJsx.ml

@@ -247,15 +247,16 @@ let getJsxLabels ~componentPath ~findTypeOfValue ~package =
         match propsType |> getPropsType with
         | Some (path, typeArgs) -> getFields ~path ~typeArgs
         | None -> [])
-      | Tarrow (Nolabel, {desc = Tconstr (path, typeArgs, _)}, _, _, _)
+      | Tarrow
+          ({lbl = Nolabel; typ = {desc = Tconstr (path, typeArgs, _)}}, _, _, _)
         when Path.last path = "props" ->
         getFields ~path ~typeArgs
       | Tconstr (clPath, [{desc = Tconstr (path, typeArgs, _)}; _], _)
         when Path.name clPath = "React.componentLike"
              && Path.last path = "props" ->
         (* JSX V4 external or interface *)
         getFields ~path ~typeArgs
-      | Tarrow (Nolabel, typ, _, _, _) -> (
+      | Tarrow ({lbl = Nolabel; typ}, _, _, _) -> (
         (* Component without the JSX PPX, like a make fn taking a hand-written
            type props. *)
         let rec digToConstr typ =

analysis/src/CreateInterface.ml

@@ -124,7 +124,10 @@ let printSignature ~extractor ~signature =
     in
     match typ.desc with
     | Tarrow
-        (_, {desc = Tconstr (Path.Pident propsId, typeArgs, _)}, retType, _, _)
+        ( {typ = {desc = Tconstr (Path.Pident propsId, typeArgs, _)}},
+          retType,
+          _,
+          _ )
       when Ident.name propsId = "props" ->
       Some (typeArgs, retType)
     | Tconstr
@@ -175,15 +178,18 @@ let printSignature ~extractor ~signature =
             in
             {
               retType with
-              desc = Tarrow (lbl, propType, mkFunType rest, Cok, None);
+              desc = Tarrow ({lbl; typ = propType}, mkFunType rest, Cok, None);
             }
         in
         let funType =
           if List.length labelDecls = 0 (* No props *) then
             let tUnit =
               Ctype.newconstr (Path.Pident (Ident.create "unit")) []
             in
-            {retType with desc = Tarrow (Nolabel, tUnit, retType, Cok, None)}
+            {
+              retType with
+              desc = Tarrow ({lbl = Nolabel; typ = tUnit}, retType, Cok, None);
+            }
           else mkFunType labelDecls
         in
         sigItemToString

analysis/src/Shared.ml

@@ -48,9 +48,9 @@ let findTypeConstructors (tel : Types.type_expr list) =
     | Tconstr (path, args, _) ->
       addPath path;
       args |> List.iter loop
-    | Tarrow (_, te1, te2, _, _) ->
-      loop te1;
-      loop te2
+    | Tarrow (arg, ret, _, _) ->
+      loop arg.typ;
+      loop ret
     | Ttuple tel -> tel |> List.iter loop
     | Tnil | Tvar _ | Tobject _ | Tfield _ | Tvariant _ | Tunivar _ | Tpackage _
       ->

analysis/src/SignatureHelp.ml

@@ -112,9 +112,7 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
       match expr with
       | {
        (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *)
-       Parsetree.ptyp_desc =
-         Ptyp_arrow
-           {lbl = argumentLabel; arg = argumentTypeExpr; ret = nextFunctionExpr};
+       Parsetree.ptyp_desc = Ptyp_arrow {arg; ret = nextFunctionExpr};
        ptyp_loc;
       } ->
         let startOffset =
@@ -123,20 +121,20 @@ let extractParameters ~signature ~typeStrForParser ~labelPrefixLen =
           |> Option.get
         in
         let endOffset =
-          argumentTypeExpr.ptyp_loc |> Loc.end_
+          arg.typ.ptyp_loc |> Loc.end_
           |> Pos.positionToOffset typeStrForParser
           |> Option.get
         in
         (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *)
         let endOffset =
-          match argumentLabel with
+          match arg.lbl with
           | Asttypes.Optional _ -> endOffset + 2
           | _ -> endOffset
         in
         extractParams nextFunctionExpr
           (params
           @ [
-              ( argumentLabel,
+              ( arg.lbl,
                 (* Remove the label prefix offset here, since we're not showing
                    that to the end user. *)
                 startOffset - labelPrefixLen,

analysis/src/TypeUtils.ml

@@ -30,7 +30,7 @@ let debugLogTypeArgContext {env; typeArgs; typeParams} =
 let rec hasTvar (ty : Types.type_expr) : bool =
   match ty.desc with
   | Tvar _ -> true
-  | Tarrow (_, ty1, ty2, _, _) -> hasTvar ty1 || hasTvar ty2
+  | Tarrow (arg, ret, _, _) -> hasTvar arg.typ || hasTvar ret
   | Ttuple tyl -> List.exists hasTvar tyl
   | Tconstr (_, tyl, _) -> List.exists hasTvar tyl
   | Tobject (ty, _) -> hasTvar ty
@@ -135,8 +135,11 @@ let instantiateType ~typeParams ~typeArgs (t : Types.type_expr) =
       | Tsubst t -> loop t
       | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
       | Tnil -> t
-      | Tarrow (lbl, t1, t2, c, arity) ->
-        {t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
+      | Tarrow (arg, ret, c, arity) ->
+        {
+          t with
+          desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
+        }
       | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
       | Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
       | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -188,8 +191,11 @@ let instantiateType2 ?(typeArgContext : typeArgContext option)
       | Tsubst t -> loop t
       | Tvariant rd -> {t with desc = Tvariant (rowDesc rd)}
       | Tnil -> t
-      | Tarrow (lbl, t1, t2, c, arity) ->
-        {t with desc = Tarrow (lbl, loop t1, loop t2, c, arity)}
+      | Tarrow (arg, ret, c, arity) ->
+        {
+          t with
+          desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
+        }
       | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)}
       | Tobject (t, r) -> {t with desc = Tobject (loop t, r)}
       | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)}
@@ -261,7 +267,7 @@ let extractFunctionType ~env ~package ?(digInto = true) typ =
   let rec loop ~env acc (t : Types.type_expr) =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
-    | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
+    | Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet
     | Tconstr (path, typeArgs, _) when digInto -> (
       match References.digConstructor ~env ~package path with
       | Some
@@ -280,7 +286,7 @@ let extractFunctionTypeWithEnv ~env ~package typ =
   let rec loop ~env acc (t : Types.type_expr) =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ~env acc t1
-    | Tarrow (label, tArg, tRet, _, _) -> loop ~env ((label, tArg) :: acc) tRet
+    | Tarrow (arg, tRet, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) tRet
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
       | Some
@@ -318,8 +324,8 @@ let extractFunctionType2 ?typeArgContext ~env ~package typ =
   let rec loop ?typeArgContext ~env acc (t : Types.type_expr) =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) -> loop ?typeArgContext ~env acc t1
-    | Tarrow (label, tArg, tRet, _, _) ->
-      loop ?typeArgContext ~env ((label, tArg) :: acc) tRet
+    | Tarrow (arg, tRet, _, _) ->
+      loop ?typeArgContext ~env ((arg.lbl, arg.typ) :: acc) tRet
     | Tconstr (path, typeArgs, _) -> (
       match References.digConstructor ~env ~package path with
       | Some
@@ -895,12 +901,12 @@ let getArgs ~env (t : Types.type_expr) ~full =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
       getArgsLoop ~full ~env ~currentArgumentPosition t1
-    | Tarrow (Labelled l, tArg, tRet, _, _) ->
+    | Tarrow ({lbl = Labelled l; typ = tArg}, tRet, _, _) ->
       (SharedTypes.Completable.Labelled l, tArg)
       :: getArgsLoop ~full ~env ~currentArgumentPosition tRet
-    | Tarrow (Optional l, tArg, tRet, _, _) ->
+    | Tarrow ({lbl = Optional l; typ = tArg}, tRet, _, _) ->
       (Optional l, tArg) :: getArgsLoop ~full ~env ~currentArgumentPosition tRet
-    | Tarrow (Nolabel, tArg, tRet, _, _) ->
+    | Tarrow ({lbl = Nolabel; typ = tArg}, tRet, _, _) ->
       (Unlabelled {argumentPosition = currentArgumentPosition}, tArg)
       :: getArgsLoop ~full ~env
            ~currentArgumentPosition:(currentArgumentPosition + 1)

compiler/frontend/ast_compatible.ml

@@ -30,8 +30,8 @@ open Parsetree
 
 let default_loc = Location.none
 
-let arrow ?loc ?attrs ~arity a b =
-  Ast_helper.Typ.arrow ?loc ?attrs ~arity Nolabel a b
+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 =
@@ -138,22 +138,30 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn
         };
   }
 
-let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt arg ret :
+let label_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret :
     core_type =
   {
     ptyp_desc =
       Ptyp_arrow
-        {lbl = Asttypes.Labelled {txt; loc = default_loc}; arg; ret; arity};
+        {
+          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 arg ret : core_type
+let opt_arrow ?(loc = default_loc) ?(attrs = []) ~arity txt typ ret : core_type
     =
   {
     ptyp_desc =
       Ptyp_arrow
-        {lbl = Asttypes.Optional {txt; loc = default_loc}; arg; ret; arity};
+        {
+          arg = {lbl = Asttypes.Optional {txt; loc = default_loc}; typ};
+          ret;
+          arity;
+        };
     ptyp_loc = loc;
     ptyp_attributes = attrs;
   }

compiler/frontend/ast_core_type.ml

@@ -142,7 +142,8 @@ 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 {lbl = label; arg = ty; ret = acc; arity = None};
+          ptyp_desc =
+            Ptyp_arrow {arg = {lbl = label; typ = ty}; ret = acc; arity = None};
           ptyp_loc = loc;
           ptyp_attributes = attr;
         })
@@ -156,9 +157,14 @@ let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t =
 let list_of_arrow (ty : t) : t * param_type list =
   let rec aux (ty : t) acc =
     match ty.ptyp_desc with
-    | Ptyp_arrow {lbl = label; arg; ret; arity} when arity = None || acc = [] ->
+    | Ptyp_arrow {arg; ret; arity} when arity = None || acc = [] ->
       aux ret
-        (({label; ty = arg; attr = ty.ptyp_attributes; loc = ty.ptyp_loc}
+        (({
+            label = arg.lbl;
+            ty = arg.typ;
+            attr = ty.ptyp_attributes;
+            loc = ty.ptyp_loc;
+          }
            : param_type)
         :: acc)
     | Ptyp_poly (_, ty) ->

compiler/frontend/ast_core_type_class_type.ml

@@ -67,17 +67,17 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ
 let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
   let loc = ty.ptyp_loc in
   match ty.ptyp_desc with
-  | Ptyp_arrow {lbl = label; arg = args; ret = body}
+  | Ptyp_arrow {arg; ret = body}
   (* let it go without regard label names,
      it will report error later when the label is not empty
   *)
     -> (
     match fst (Ast_attributes.process_attributes_rev ty.ptyp_attributes) with
     | Meth_callback _ ->
-      Ast_typ_uncurry.to_method_callback_type loc self label args body
+      Ast_typ_uncurry.to_method_callback_type loc self arg.lbl arg.typ body
     | Method _ ->
       (* Treat @meth as making the type uncurried, for backwards compatibility *)
-      Ast_typ_uncurry.to_uncurry_type loc self label args body
+      Ast_typ_uncurry.to_uncurry_type loc self arg.lbl arg.typ body
     | Nothing -> Bs_ast_mapper.default_mapper.typ self ty)
   | Ptyp_object (methods, closed_flag) ->
     let ( +> ) attr (typ : Parsetree.core_type) =

compiler/frontend/ast_exp_handle_external.ml

@@ -44,7 +44,9 @@ 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) Nolabel (Typ.any ()) (Typ.any ()))
+            (Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Typ.any ()}
+               (Typ.any ()))
           [str_exp];
     }
   in
@@ -70,7 +72,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) Nolabel (Typ.any ())
+        (Typ.arrow ~arity:(Some 1)
+           {lbl = Nolabel; typ = Typ.any ()}
            (Ast_literal.type_unit ()))
       [Ast_literal.val_unit ~loc ()]
   | _ ->
@@ -96,7 +99,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) Nolabel (Typ.any ()) (Typ.any ()))
+            (Typ.arrow ~arity:(Some 1)
+               {lbl = Nolabel; typ = Typ.any ()}
+               (Typ.any ()))
           [exp];
       pexp_attributes =
         (match !is_function with
@@ -123,11 +128,12 @@ let handle_ffi ~loc ~payload =
       let any = Ast_helper.Typ.any ~loc:e.pexp_loc () in
       let unit = Ast_literal.type_unit ~loc () in
       let rec arrow ~arity =
-        if arity = 0 then Ast_helper.Typ.arrow ~arity:None ~loc Nolabel unit any
+        if arity = 0 then
+          Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = unit} any
         else if arity = 1 then
-          Ast_helper.Typ.arrow ~arity:None ~loc Nolabel any any
+          Ast_helper.Typ.arrow ~arity:None ~loc {lbl = Nolabel; typ = any} any
         else
-          Ast_helper.Typ.arrow ~loc ~arity:None Nolabel any
+          Ast_helper.Typ.arrow ~loc ~arity:None {lbl = Nolabel; typ = any}
             (arrow ~arity:(arity - 1))
       in
       match !is_function with
@@ -146,7 +152,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) Nolabel (Typ.any ()) (Typ.any ()))
+              (Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Typ.any ()}
+                 (Typ.any ()))
             [exp];
         pexp_attributes =
           (match !is_function with
@@ -163,7 +171,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) Nolabel (Typ.any ()) (Typ.any ()))
+              (Typ.arrow ~arity:(Some 1)
+                 {lbl = Nolabel; typ = Typ.any ()}
+                 (Typ.any ()))
             [exp];
       }
   | None ->

compiler/frontend/ast_typ_uncurry.ml

@@ -33,7 +33,9 @@ let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper)
     (typ : Parsetree.core_type) =
   let first_arg = mapper.typ mapper first_arg in
   let typ = mapper.typ mapper typ in
-  let meth_type = Typ.arrow ~loc ~arity:None label first_arg typ in
+  let meth_type =
+    Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ
+  in
   let arity = Ast_core_type.get_uncurry_arity meth_type in
   match arity with
   | Some n ->
@@ -57,7 +59,7 @@ let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper)
   let first_arg = mapper.typ mapper first_arg in
   let typ = mapper.typ mapper typ in
 
-  let fn_type = Typ.arrow ~loc ~arity:None label first_arg typ in
+  let fn_type = Typ.arrow ~loc ~arity:None {lbl = label; typ = first_arg} typ in
   let arity = Ast_core_type.get_uncurry_arity fn_type in
   let fn_type =
     match fn_type.ptyp_desc with