Allow labeled arguments in any order for inferred function types

CHANGELOG.md

@@ -31,6 +31,8 @@
 
 #### :nail_care: Polish
 
+- Allow inferred labeled functions to be called with labels in any order by removing legacy curried-arrow commutation locks. https://github.com/rescript-lang/rescript/pull/8547
+
 #### :house: Internal
 
 - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534

analysis/reanalyze/src/dead_optional_args.ml

@@ -24,17 +24,17 @@ let add_function_reference ~config ~decls ~cross_file ~(loc_from : Location.t)
 let rec has_optional_args (texpr : Types.type_expr) =
   match texpr.desc with
   | _ when not (active ()) -> false
-  | Tarrow ({lbl = Optional _}, _tTo, _, _) -> true
-  | Tarrow (_, t_to, _, _) -> has_optional_args t_to
+  | Tarrow ({lbl = Optional _}, _tTo, _) -> true
+  | Tarrow (_, t_to, _) -> has_optional_args t_to
   | Tlink t -> has_optional_args t
   | Tsubst t -> has_optional_args t
   | _ -> false
 
 let rec from_type_expr (texpr : Types.type_expr) =
   match texpr.desc with
   | _ when not (active ()) -> []
-  | Tarrow ({lbl = Optional {txt = s}}, t_to, _, _) -> s :: from_type_expr t_to
-  | Tarrow (_, t_to, _, _) -> from_type_expr t_to
+  | Tarrow ({lbl = Optional {txt = s}}, t_to, _) -> s :: from_type_expr t_to
+  | Tarrow (_, t_to, _) -> from_type_expr t_to
   | Tlink t -> from_type_expr t
   | Tsubst t -> from_type_expr t
   | _ -> []

analysis/src/completion_back_end.ml

@@ -1098,10 +1098,7 @@ and get_completions_for_context_path ~state ~debug ~full ~opens ~raw_opens ~pos
         | [] -> t_ret
         | (label, t_arg) :: rest ->
           let rest_type = reconstruct_function_type rest t_ret in
-          {
-            typ with
-            desc = Tarrow ({lbl = label; typ = t_arg}, rest_type, Cok, None);
-          }
+          {typ with desc = Tarrow ({lbl = label; typ = t_arg}, rest_type, None)}
       in
       let rec process_apply args labels =
         match (args, labels) with

analysis/src/completion_jsx.ml

@@ -246,15 +246,15 @@ let get_jsx_labels ~component_path ~find_type_of_value ~package ~state =
         | Some (path, type_args) -> get_fields ~path ~type_args
         | None -> [])
       | Tarrow
-          ({lbl = Nolabel; typ = {desc = Tconstr (path, type_args, _)}}, _, _, _)
+          ({lbl = Nolabel; typ = {desc = Tconstr (path, type_args, _)}}, _, _)
         when Path.last path = "props" ->
         get_fields ~path ~type_args
       | Tconstr (cl_path, [{desc = Tconstr (path, type_args, _)}; _], _)
         when Path.name cl_path = "React.componentLike"
              && Path.last path = "props" ->
         (* JSX V4 external or interface *)
         get_fields ~path ~type_args
-      | Tarrow ({lbl = Nolabel; typ}, _, _, _) -> (
+      | Tarrow ({lbl = Nolabel; typ}, _, _) -> (
         (* Component without the JSX PPX, like a make fn taking a hand-written
            type props. *)
         let rec dig_to_constr typ =

analysis/src/create_interface.ml

@@ -123,7 +123,6 @@ let print_signature ~extractor ~signature =
     | Tarrow
         ( {typ = {desc = Tconstr (Path.Pident props_id, type_args, _)}},
           ret_type,
-          _,
           _ )
       when Ident.name props_id = "props" ->
       Some (type_args, ret_type)
@@ -176,7 +175,7 @@ let print_signature ~extractor ~signature =
             in
             {
               ret_type with
-              desc = Tarrow ({lbl; typ = prop_type}, mk_fun_type rest, Cok, None);
+              desc = Tarrow ({lbl; typ = prop_type}, mk_fun_type rest, None);
             }
         in
         let fun_type =
@@ -186,7 +185,7 @@ let print_signature ~extractor ~signature =
             in
             {
               ret_type with
-              desc = Tarrow ({lbl = Nolabel; typ = t_unit}, ret_type, Cok, None);
+              desc = Tarrow ({lbl = Nolabel; typ = t_unit}, ret_type, None);
             }
           else mk_fun_type label_decls
         in

analysis/src/shared.ml

@@ -48,7 +48,7 @@ let find_type_constructors (tel : Types.type_expr list) =
     | Tconstr (path, args, _) ->
       add_path path;
       args |> List.iter loop
-    | Tarrow (arg, ret, _, _) ->
+    | Tarrow (arg, ret, _) ->
       loop arg.typ;
       loop ret
     | Ttuple tel -> tel |> List.iter loop

analysis/src/type_utils.ml

@@ -30,7 +30,7 @@ let debug_log_type_arg_context {env; type_args; type_params} =
 let rec has_tvar (ty : Types.type_expr) : bool =
   match ty.desc with
   | Tvar _ -> true
-  | Tarrow (arg, ret, _, _) -> has_tvar arg.typ || has_tvar ret
+  | Tarrow (arg, ret, _) -> has_tvar arg.typ || has_tvar ret
   | Ttuple tyl -> List.exists has_tvar tyl
   | Tconstr (_, tyl, _) -> List.exists has_tvar tyl
   | Tobject (ty, _) -> has_tvar ty
@@ -144,11 +144,8 @@ let instantiate_type ~type_params ~type_args (t : Types.type_expr) =
       | Tsubst t -> loop t
       | Tvariant rd -> {t with desc = Tvariant (row_desc rd)}
       | Tnil -> t
-      | Tarrow (arg, ret, c, arity) ->
-        {
-          t with
-          desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
-        }
+      | Tarrow (arg, ret, arity) ->
+        {t with desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, 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)}
@@ -200,11 +197,8 @@ let instantiate_type2 ?(type_arg_context : type_arg_context option)
       | Tsubst t -> loop t
       | Tvariant rd -> {t with desc = Tvariant (row_desc rd)}
       | Tnil -> t
-      | Tarrow (arg, ret, c, arity) ->
-        {
-          t with
-          desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity);
-        }
+      | Tarrow (arg, ret, arity) ->
+        {t with desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, 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)}
@@ -272,7 +266,7 @@ let extract_function_type ~state ~env ~package ?(dig_into = 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 (arg, t_ret, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret
+    | Tarrow (arg, t_ret, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret
     | Tconstr (path, type_args, _) when dig_into -> (
       match References.dig_constructor ~state ~env ~package path with
       | Some (env, {item = {decl = {type_manifest = Some t1; type_params}}}) ->
@@ -287,7 +281,7 @@ let extract_function_type_with_env ~state ~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 (arg, t_ret, _, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret
+    | Tarrow (arg, t_ret, _) -> loop ~env ((arg.lbl, arg.typ) :: acc) t_ret
     | Tconstr (path, type_args, _) -> (
       match References.dig_constructor ~state ~env ~package path with
       | Some (_env, {item = {decl = {type_manifest = Some t1; type_params}}}) ->
@@ -323,7 +317,7 @@ let extract_function_type2 ?type_arg_context ~state ~env ~package typ =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
       loop ?type_arg_context ~env acc t1
-    | Tarrow (arg, t_ret, _, _) ->
+    | Tarrow (arg, t_ret, _) ->
       loop ?type_arg_context ~env ((arg.lbl, arg.typ) :: acc) t_ret
     | Tconstr (path, type_args, _) -> (
       match References.dig_constructor ~state ~env ~package path with
@@ -927,13 +921,13 @@ let get_args ~env (t : Types.type_expr) ~full ~state =
     match t.desc with
     | Tlink t1 | Tsubst t1 | Tpoly (t1, []) ->
       get_args_loop ~full ~env ~current_argument_position t1
-    | Tarrow ({lbl = Labelled {txt = l}; typ = t_arg}, t_ret, _, _) ->
+    | Tarrow ({lbl = Labelled {txt = l}; typ = t_arg}, t_ret, _) ->
       (Shared_types.Completable.Labelled l, t_arg)
       :: get_args_loop ~full ~env ~current_argument_position t_ret
-    | Tarrow ({lbl = Optional {txt = l}; typ = t_arg}, t_ret, _, _) ->
+    | Tarrow ({lbl = Optional {txt = l}; typ = t_arg}, t_ret, _) ->
       (Optional l, t_arg)
       :: get_args_loop ~full ~env ~current_argument_position t_ret
-    | Tarrow ({lbl = Nolabel; typ = t_arg}, t_ret, _, _) ->
+    | Tarrow ({lbl = Nolabel; typ = t_arg}, t_ret, _) ->
       (Unlabelled {argument_position = current_argument_position}, t_arg)
       :: get_args_loop ~full ~env
            ~current_argument_position:(current_argument_position + 1)

compiler/gentype/translate_type_expr_from_types.ml

@@ -467,7 +467,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 ({lbl = Nolabel; typ = 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 ->
@@ -484,7 +484,6 @@ let rec translate_arrow_type ~config ~type_vars_gen ~type_env ~rev_arg_deps
           typ = type_expr1;
         },
         type_expr2,
-        _,
         arity )
     when arity = None || rev_args = [] -> (
     match type_expr1 |> remove_option ~label with

compiler/ml/btype.ml

@@ -83,7 +83,6 @@ type change =
       (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
   | Crow of row_field option ref * row_field option
   | Ckind of field_kind option ref * field_kind option
-  | Ccommu of commutable ref * commutable
   | Cuniv of type_expr option ref * type_expr option
   | Ctypeset of Type_set.t ref * Type_set.t
 
@@ -122,10 +121,6 @@ let repr t =
     repr_link false t d t'
   | _ -> t
 
-let rec commu_repr = function
-  | Clink r when !r <> Cunknown -> commu_repr !r
-  | c -> c
-
 let rec row_field_repr_aux tl = function
   | Reither (_, tl', _, {contents = Some fi}) ->
     row_field_repr_aux (tl @ tl') fi
@@ -260,7 +255,7 @@ let rec iter_row f row =
 let iter_type_expr f ty =
   match ty.desc with
   | Tvar _ -> ()
-  | Tarrow ({typ = ty1}, ty2, _, _) ->
+  | Tarrow ({typ = ty1}, ty2, _) ->
     f ty1;
     f ty2
   | Ttuple l -> List.iter f l
@@ -413,8 +408,6 @@ let rec copy_kind = function
   | Fpresent -> Fpresent
   | Fabsent -> assert false
 
-let copy_commu c = if commu_repr c = Cok then Cok else Clink (ref Cunknown)
-
 (* Since univars may be used as row variables, we need to do some
    encoding during substitution *)
 let rec norm_univar ty =
@@ -426,8 +419,7 @@ 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 (arg, ret, c, arity) ->
-    Tarrow ({arg with typ = f arg.typ}, f ret, copy_commu c, arity)
+  | Tarrow (arg, ret, arity) -> Tarrow ({arg with typ = f arg.typ}, f ret, 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)}) ->
@@ -631,7 +623,6 @@ let undo_change = function
   | Cname (r, v) -> r := v
   | Crow (r, v) -> r := v
   | Ckind (r, v) -> r := v
-  | Ccommu (r, v) -> r := v
   | Cuniv (r, v) -> r := v
   | Ctypeset (r, v) -> r := v
 
@@ -677,9 +668,6 @@ let set_row_field e v =
 let set_kind rk k =
   log_change (Ckind (rk, !rk));
   rk := Some k
-let set_commu rc c =
-  log_change (Ccommu (rc, !rc));
-  rc := c
 let set_typeset rs s =
   log_change (Ctypeset (rs, !rs));
   rs := s

compiler/ml/btype.mli

@@ -59,9 +59,6 @@ val field_kind_repr : field_kind -> field_kind
 (* Return the canonical representative of an object field
    kind. *)
 
-val commu_repr : commutable -> commutable
-(* Return the canonical representative of a commutation lock *)
-
 (**** polymorphic variants ****)
 
 val row_repr : row_desc -> row_desc
@@ -224,7 +221,6 @@ val set_name :
 val set_row_field : row_field option ref -> row_field -> unit
 val set_univar : type_expr option ref -> type_expr -> unit
 val set_kind : field_kind option ref -> field_kind -> unit
-val set_commu : commutable ref -> commutable -> unit
 val set_typeset : Type_set.t ref -> Type_set.t -> unit
 (* Set references, logging the old value *)
 

compiler/ml/ctype.ml

@@ -714,7 +714,7 @@ 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 (arg, ret, _, _) ->
+    | 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)
@@ -1912,7 +1912,7 @@ let rec mcomp type_pairs env t1 t2 =
             Type_pairs.add type_pairs (t1', t2') ();
             match (t1'.desc, t2'.desc) with
             | Tvar _, Tvar _ -> assert false
-            | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+            | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
               when Asttypes.same_arg_label arg1.lbl arg2.lbl
                    || not (is_optional arg1.lbl || is_optional arg2.lbl) ->
               mcomp type_pairs env arg1.typ arg2.typ;
@@ -2327,17 +2327,13 @@ and unify3 env t1 t1' t2 t2' =
     | Pattern -> add_type_equality t1' t2');
     try
       (match (d1, d2) with
-      | Tarrow (arg1, ret1, c1, a1), Tarrow (arg2, ret2, c2, a2)
+      | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2)
         when a1 = a2
              && (Asttypes.same_arg_label arg1.lbl arg2.lbl
                 || !umode = Pattern
-                   && not (is_optional arg1.lbl || is_optional arg2.lbl)) -> (
+                   && 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
-        | _ -> ())
+        unify env ret1 ret2
       | Ttuple tl1, Ttuple tl2 -> unify_list env tl1 tl2
       | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 ->
         if !umode = Expression || not !generate_equations then
@@ -2778,11 +2774,10 @@ 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 ({lbl = l; typ = t1}, t2, Cok, arity)) in
+    let t' = newty2 lv (Tarrow ({lbl = l; typ = t1}, t2, arity)) in
     link_type t t';
     (t1, t2)
-  | Tarrow (arg, ret, _, _) when Asttypes.same_arg_label l arg.lbl ->
-    (arg.typ, ret)
+  | Tarrow (arg, ret, _) when Asttypes.same_arg_label l arg.lbl -> (arg.typ, ret)
   | _ -> raise (Unify [])
 
 (* Used by [filter_method]. *)
@@ -2896,7 +2891,7 @@ 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 (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+              | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
                 when Asttypes.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
@@ -3166,7 +3161,7 @@ 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 (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+              | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
                 when Asttypes.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
@@ -3383,14 +3378,14 @@ let rec build_subtype env visited loops posi level t =
         (t', Equiv)
       with Not_found -> (t, Unchanged)
     else (t, Unchanged)
-  | Tarrow (arg, ret, _, 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 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 ({arg with typ = t1}, t2, Cok, a)), c)
+      if c > Unchanged then (newty (Tarrow ({arg with typ = t1}, t2, a)), c)
       else (t, Unchanged)
   | Ttuple tlist ->
     if memq_warn t visited then (t, Unchanged)
@@ -3583,7 +3578,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
       Type_pairs.add subtypes (t1, t2) ();
       match (t1.desc, t2.desc) with
       | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs
-      | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _)
+      | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _)
         when Asttypes.same_arg_label arg1.lbl arg2.lbl ->
         let cstrs =
           subtype_rec env
@@ -4065,7 +4060,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 (_, ret, _, _) -> 1 + arity ret
+  | Tarrow (_, ret, _) -> 1 + arity ret
   | _ -> 0
 
 (* Check whether an abbreviation expands to itself. *)
@@ -4431,5 +4426,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