Adapt arrow type in Types.

Author: cristianoc

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/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/gentype/TranslateTypeExprFromTypes.ml

@@ -290,7 +290,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
   | Tlink t ->
     translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
       ~rev_args t
-  | Tarrow (Nolabel, type_expr1, type_expr2, _, arity)
+  | Tarrow ({lbl = Nolabel; typ = type_expr1}, type_expr2, _, arity)
     when arity = None || rev_args = [] ->
     let {dependencies; type_} =
       type_expr1 |> fun __x ->
@@ -302,8 +302,7 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
          ~rev_arg_deps:next_rev_deps
          ~rev_args:((Nolabel, type_) :: rev_args)
   | Tarrow
-      ( ((Labelled lbl | Optional lbl) as label),
-        type_expr1,
+      ( {lbl = (Labelled lbl | Optional lbl) as label; typ = type_expr1},
         type_expr2,
         _,
         arity )

compiler/ml/btype.ml

@@ -260,7 +260,7 @@ let rec iter_row f row =
 let iter_type_expr f ty =
   match ty.desc with
   | Tvar _ -> ()
-  | Tarrow (_, ty1, ty2, _, _) ->
+  | Tarrow ({typ = ty1}, ty2, _, _) ->
     f ty1;
     f ty2
   | Ttuple l -> List.iter f l
@@ -428,8 +428,8 @@ let rec norm_univar ty =
 
 let rec copy_type_desc ?(keep_names = false) f = function
   | Tvar _ as ty -> if keep_names then ty else Tvar None
-  | Tarrow (p, ty1, ty2, c, arity) ->
-    Tarrow (p, f ty1, f ty2, copy_commu c, arity)
+  | Tarrow (arg, ret, c, arity) ->
+    Tarrow ({arg with typ = f arg.typ}, f ret, copy_commu c, arity)
   | Ttuple l -> Ttuple (List.map f l)
   | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil)
   | Tobject (ty, {contents = Some (p, tl)}) ->

compiler/ml/ctype.ml

@@ -732,9 +732,9 @@ let rec generalize_expansive env var_level visited ty =
           else generalize_expansive env var_level visited t)
         variance tyl
     | Tpackage (_, _, tyl) -> List.iter (generalize_structure var_level) tyl
-    | Tarrow (_, t1, t2, _, _) ->
-      generalize_structure var_level t1;
-      generalize_expansive env var_level visited t2
+    | Tarrow (arg, ret, _, _) ->
+      generalize_structure var_level arg.typ;
+      generalize_expansive env var_level visited ret
     | _ -> iter_type_expr (generalize_expansive env var_level visited) ty)
 
 let generalize_expansive env ty =
@@ -1926,11 +1926,11 @@ let rec mcomp type_pairs env t1 t2 =
             TypePairs.add type_pairs (t1', t2') ();
             match (t1'.desc, t2'.desc) with
             | Tvar _, Tvar _ -> assert false
-            | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
-              when Asttypes.Noloc.same_arg_label l1 l2
-                   || not (is_optional l1 || is_optional l2) ->
-              mcomp type_pairs env t1 t2;
-              mcomp type_pairs env u1 u2
+            | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+              when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl
+                   || not (is_optional arg1.lbl || is_optional arg2.lbl) ->
+              mcomp type_pairs env arg1.typ arg2.typ;
+              mcomp type_pairs env ret1 ret2
             | Ttuple tl1, Ttuple tl2 -> mcomp_list type_pairs env tl1 tl2
             | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) ->
               mcomp_type_decl type_pairs env p1 p2 tl1 tl2
@@ -2342,13 +2342,13 @@ and unify3 env t1 t1' t2 t2' =
     | Pattern -> add_type_equality t1' t2');
     try
       (match (d1, d2) with
-      | Tarrow (l1, t1, u1, c1, a1), Tarrow (l2, t2, u2, c2, a2)
+      | Tarrow (arg1, ret1, c1, a1), Tarrow (arg2, ret2, c2, a2)
         when a1 = a2
-             && (Asttypes.Noloc.same_arg_label l1 l2
-                || (!umode = Pattern && not (is_optional l1 || is_optional l2))
-                ) -> (
-        unify env t1 t2;
-        unify env u1 u2;
+             && (Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl
+                || !umode = Pattern
+                   && not (is_optional arg1.lbl || is_optional arg2.lbl)) -> (
+        unify env arg1.typ arg2.typ;
+        unify env ret1 ret2;
         match (commu_repr c1, commu_repr c2) with
         | Clink r, c2 -> set_commu r c2
         | c1, Clink r -> set_commu r c1
@@ -2796,10 +2796,11 @@ let filter_arrow ~env ~arity t l =
   | Tvar _ ->
     let lv = t.level in
     let t1 = newvar2 lv and t2 = newvar2 lv in
-    let t' = newty2 lv (Tarrow (l, t1, t2, Cok, arity)) in
+    let t' = newty2 lv (Tarrow ({lbl = l; typ = t1}, t2, Cok, arity)) in
     link_type t t';
     (t1, t2)
-  | Tarrow (l', t1, t2, _, _) when Asttypes.Noloc.same_arg_label l l' -> (t1, t2)
+  | Tarrow (arg, ret, _, _) when Asttypes.Noloc.same_arg_label l arg.lbl ->
+    (arg.typ, ret)
   | _ -> raise (Unify [])
 
 (* Used by [filter_method]. *)
@@ -2913,10 +2914,10 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
               | Tvar _, _ when may_instantiate inst_nongen t1' ->
                 moregen_occur env t1'.level t2;
                 link_type t1' t2
-              | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
-                when Asttypes.Noloc.same_arg_label l1 l2 ->
-                moregen inst_nongen type_pairs env t1 t2;
-                moregen inst_nongen type_pairs env u1 u2
+              | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+                when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
+                moregen inst_nongen type_pairs env arg1.typ arg2.typ;
+                moregen inst_nongen type_pairs env ret1 ret2
               | Ttuple tl1, Ttuple tl2 ->
                 moregen_list inst_nongen type_pairs env tl1 tl2
               | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2
@@ -3183,10 +3184,10 @@ let rec eqtype rename type_pairs subst env t1 t2 =
                   if List.exists (fun (_, t) -> t == t2') !subst then
                     raise (Unify []);
                   subst := (t1', t2') :: !subst)
-              | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
-                when Asttypes.Noloc.same_arg_label l1 l2 ->
-                eqtype rename type_pairs subst env t1 t2;
-                eqtype rename type_pairs subst env u1 u2
+              | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+                when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
+                eqtype rename type_pairs subst env arg1.typ arg2.typ;
+                eqtype rename type_pairs subst env ret1 ret2
               | Ttuple tl1, Ttuple tl2 ->
                 eqtype_list rename type_pairs subst env tl1 tl2
               | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2
@@ -3396,14 +3397,14 @@ let rec build_subtype env visited loops posi level t =
         (t', Equiv)
       with Not_found -> (t, Unchanged)
     else (t, Unchanged)
-  | Tarrow (l, t1, t2, _, a) ->
+  | Tarrow (arg, ret, _, a) ->
     if memq_warn t visited then (t, Unchanged)
     else
       let visited = t :: visited in
-      let t1', c1 = build_subtype env visited loops (not posi) level t1 in
-      let t2', c2 = build_subtype env visited loops posi level t2 in
+      let t1, c1 = build_subtype env visited loops (not posi) level arg.typ in
+      let t2, c2 = build_subtype env visited loops posi level ret in
       let c = max c1 c2 in
-      if c > Unchanged then (newty (Tarrow (l, t1', t2', Cok, a)), c)
+      if c > Unchanged then (newty (Tarrow ({arg with typ = t1}, t2, Cok, a)), c)
       else (t, Unchanged)
   | Ttuple tlist ->
     if memq_warn t visited then (t, Unchanged)
@@ -3596,10 +3597,14 @@ let rec subtype_rec env trace t1 t2 cstrs =
       TypePairs.add subtypes (t1, t2) ();
       match (t1.desc, t2.desc) with
       | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs
-      | Tarrow (l1, t1, u1, _, _), Tarrow (l2, t2, u2, _, _)
-        when Asttypes.Noloc.same_arg_label l1 l2 ->
-        let cstrs = subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs in
-        subtype_rec env ((u1, u2) :: trace) u1 u2 cstrs
+      | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+        when Asttypes.Noloc.same_arg_label arg1.lbl arg2.lbl ->
+        let cstrs =
+          subtype_rec env
+            ((arg2.typ, arg1.typ) :: trace)
+            arg2.typ arg1.typ cstrs
+        in
+        subtype_rec env ((ret1, ret2) :: trace) ret1 ret2 cstrs
       | Ttuple tl1, Ttuple tl2 ->
         (* TODO(subtype-errors) Tuple as context *)
         subtype_list env trace tl1 tl2 cstrs
@@ -4074,7 +4079,7 @@ let unalias ty =
 (* Return the arity (as for curried functions) of the given type. *)
 let rec arity ty =
   match (repr ty).desc with
-  | Tarrow (_, _t1, t2, _, _) -> 1 + arity t2
+  | Tarrow (_, ret, _, _) -> 1 + arity ret
   | _ -> 0
 
 (* Check whether an abbreviation expands to itself. *)
@@ -4440,5 +4445,5 @@ let maybe_pointer_type env typ =
 
 let get_arity env typ =
   match (expand_head env typ).desc with
-  | Tarrow (_, _, _, _, arity) -> arity
+  | Tarrow (_, _, _, arity) -> arity
   | _ -> None