From a7c4c90a4e11be3f7e067e4f7ad27d5373cfc16d Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 12:58:02 +0200 Subject: [PATCH] Allow labeled arguments in any order for inferred function types Remove the legacy commutable flag from Tarrow, together with its plumbing (commu_repr, set_commu, copy_commu, the Ccommu undo-log entry) and the Incoherent_label_order error. Labeled arguments now commute at every call site regardless of whether the function type was declared or inferred; unification still requires labels in matching order, so call sites and callees always agree on the positional argument order in the generated JavaScript. Co-Authored-By: Claude Fable 5 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 2 + analysis/reanalyze/src/dead_optional_args.ml | 8 +- analysis/src/completion_back_end.ml | 5 +- analysis/src/completion_jsx.ml | 4 +- analysis/src/create_interface.ml | 5 +- analysis/src/shared.ml | 2 +- analysis/src/type_utils.ml | 28 +++---- .../gentype/translate_type_expr_from_types.ml | 3 +- compiler/ml/btype.ml | 16 +--- compiler/ml/btype.mli | 4 - compiler/ml/ctype.ml | 33 ++++---- compiler/ml/printtyp.ml | 16 ++-- compiler/ml/record_type_spread.ml | 7 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 77 ++++++------------- compiler/ml/typecore.mli | 1 - compiler/ml/typedecl.ml | 4 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/types.ml | 4 +- compiler/ml/types.mli | 33 +------- compiler/ml/typetexp.ml | 2 +- tests/ERROR_VARIANTS.md | 6 -- ...labeled_args_incoherent_order.res.expected | 10 --- .../labeled_args_incoherent_order.res | 1 - tests/tests/src/label_uncurry.mjs | 8 ++ tests/tests/src/label_uncurry.res | 3 + tools/src/tools.ml | 2 +- 27 files changed, 94 insertions(+), 194 deletions(-) delete mode 100644 tests/build_tests/super_errors/expected/labeled_args_incoherent_order.res.expected delete mode 100644 tests/build_tests/super_errors/fixtures/labeled_args_incoherent_order.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 65d4fd57259..8eb36f103bf 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/analysis/reanalyze/src/dead_optional_args.ml b/analysis/reanalyze/src/dead_optional_args.ml index 21311815398..6e14e9a576a 100644 --- a/analysis/reanalyze/src/dead_optional_args.ml +++ b/analysis/reanalyze/src/dead_optional_args.ml @@ -24,8 +24,8 @@ 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 @@ -33,8 +33,8 @@ let rec has_optional_args (texpr : Types.type_expr) = 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 | _ -> [] diff --git a/analysis/src/completion_back_end.ml b/analysis/src/completion_back_end.ml index 3f63bb53027..cbdece744ea 100644 --- a/analysis/src/completion_back_end.ml +++ b/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 diff --git a/analysis/src/completion_jsx.ml b/analysis/src/completion_jsx.ml index bfaf3bb5e99..cb591da2d40 100644 --- a/analysis/src/completion_jsx.ml +++ b/analysis/src/completion_jsx.ml @@ -246,7 +246,7 @@ 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, _)}; _], _) @@ -254,7 +254,7 @@ let get_jsx_labels ~component_path ~find_type_of_value ~package ~state = && 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 = diff --git a/analysis/src/create_interface.ml b/analysis/src/create_interface.ml index e9eee9575c4..de037a0019e 100644 --- a/analysis/src/create_interface.ml +++ b/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 diff --git a/analysis/src/shared.ml b/analysis/src/shared.ml index d5467fc2288..011b990d067 100644 --- a/analysis/src/shared.ml +++ b/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 diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index fd0c125a703..ddec5318332 100644 --- a/analysis/src/type_utils.ml +++ b/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) diff --git a/compiler/gentype/translate_type_expr_from_types.ml b/compiler/gentype/translate_type_expr_from_types.ml index a55756c0645..193848fe086 100644 --- a/compiler/gentype/translate_type_expr_from_types.ml +++ b/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 diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 1eeed117f44..31efeab2cff 100644 --- a/compiler/ml/btype.ml +++ b/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 diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli index 02a04a7e062..d4ae22fff54 100644 --- a/compiler/ml/btype.mli +++ b/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 *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index b07920b6493..4fd0d76abc6 100644 --- a/compiler/ml/ctype.ml +++ b/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 diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index f1bfdd22609..d38e26bbae6 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -131,12 +131,6 @@ let rec safe_kind_repr v = function | Fpresent -> "Fpresent" | Fabsent -> "Fabsent" -let rec safe_commu_repr v = function - | Cok -> "Cok" - | Cunknown -> "Cunknown" - | Clink r -> - if List.memq r v then "Clink loop" else safe_commu_repr (r :: v) !r - let rec safe_repr v = function | {desc = Tlink t} when not (List.memq t v) -> safe_repr (t :: v) t | t -> t @@ -172,10 +166,10 @@ and raw_type_list tl = raw_list raw_type tl and raw_type_desc ppf = function | Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow (arg, ret, c, a) -> - fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s,@,%s)@]" + | Tarrow (arg, ret, a) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" (string_of_label arg.lbl) raw_type arg.typ raw_type ret - (safe_commu_repr [] c) (string_of_arity a) + (string_of_arity a) | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl | Tconstr (p, tl, abbrev) -> fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl @@ -515,7 +509,7 @@ let rec mark_loops_rec visited ty = let visited = px :: visited in match ty.desc with | Tvar _ -> add_named_var ty - | Tarrow (arg, ret, _, _) -> + | Tarrow (arg, ret, _) -> mark_loops_rec visited arg.typ; mark_loops_rec visited ret | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl @@ -620,7 +614,7 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = let non_gen = is_non_gen sch ty in let name_gen = if non_gen then new_weak_name ty else new_name in Otyp_var (non_gen, name_of_type name_gen ty) - | Tarrow (arg, ret, _, arity) -> + | Tarrow (arg, ret, arity) -> let lab = string_of_label arg.lbl in let t1 = if is_optional arg.lbl then diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml index 0156db4b99c..ca28e07c7c8 100644 --- a/compiler/ml/record_type_spread.ml +++ b/compiler/ml/record_type_spread.ml @@ -22,11 +22,8 @@ let substitute_types ~type_map (t : Types.type_expr) = | Tsubst t -> {t with desc = Tsubst (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)} diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 69fbcab4729..3ecb5b77f98 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -707,7 +707,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let prim = let expanded = Ctype.expand_head e.exp_env e.exp_type in match (Btype.repr expanded).desc with - | Tarrow ({lbl = Nolabel; typ}, _, _, _) -> ( + | Tarrow ({lbl = Nolabel; typ}, _, _) -> ( match (Ctype.expand_head e.exp_env typ).desc with | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit | _ -> Pjs_fn_make arity) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 8bb9c672ddc..a6fc704bd48 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -63,7 +63,6 @@ type error = | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Not_a_variant_type of Longident.t - | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list | Modules_not_allowed | Cannot_infer_signature @@ -753,9 +752,9 @@ let show_extra_help ppf _env trace = let rec collect_missing_arguments env type1 type2 = match type1 with (* why do we use Ctype.matches here? Please see https://github.com/rescript-lang/rescript-compiler/pull/2554 *) - | {Types.desc = Tarrow (arg, ret, _, _)} when Ctype.matches env ret type2 -> + | {Types.desc = Tarrow (arg, ret, _)} when Ctype.matches env ret type2 -> Some [(arg.lbl, arg.typ)] - | {desc = Tarrow (arg, ret, _, _)} -> ( + | {desc = Tarrow (arg, ret, _)} -> ( match collect_missing_arguments env ret type2 with | Some res -> Some ((arg.lbl, arg.typ) :: res) | None -> None) @@ -1974,7 +1973,7 @@ let rec approx_type env sty = match sty.ptyp_desc with | Ptyp_arrow {arg = {lbl = p}; ret = sty; arity} -> let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow ({lbl = p; typ = ty1}, approx_type env sty, Cok, arity)) + newty (Tarrow ({lbl = p; typ = ty1}, approx_type env sty, arity)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> ( try @@ -1992,7 +1991,7 @@ let rec type_approx env sexp = | Pexp_let (_, _, e) -> type_approx env e | Pexp_fun {arg_label = p; rhs = e; arity} -> let ty = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, Cok, arity)) + newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, arity)) | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) @@ -2021,19 +2020,6 @@ let rec type_approx env sexp = ty2 | _ -> newvar () -(* List labels in a function type, and whether return type is a variable *) -let rec list_labels_aux env visited ls ty_fun = - let ty = expand_head env ty_fun in - if List.memq ty visited then (List.rev ls, false) - else - match ty.desc with - | Tarrow (arg, ty_res, _, arity) when arity = None || visited = [] -> - list_labels_aux env (ty :: visited) (arg.lbl :: ls) ty_res - | _ -> (List.rev ls, is_Tvar ty) - -let list_labels env ty = - wrap_trace_gadt_instances env (list_labels_aux env [] []) ty - (* Check that all univars are safe in a type *) let check_univars env expans kind exp ty_expected vars = if expans && not (is_nonexpansive exp) then @@ -2300,7 +2286,7 @@ let rec lower_args env seen ty_fun = if List.memq ty seen then () else match ty.desc with - | Tarrow (arg, ty_fun, _com, _) -> + | Tarrow (arg, ty_fun, _) -> (try unify_var env (newvar ()) arg.typ with Unify _ -> assert false); lower_args env (ty :: seen) ty_fun | _ -> () @@ -3564,7 +3550,7 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l | None -> ty_expected_ | Some arity -> let fun_t = - newty (Tarrow ({lbl = l; typ = newvar ()}, newvar (), Cok, Some arity)) + newty (Tarrow ({lbl = l; typ = newvar ()}, newvar (), Some arity)) in unify_exp_types ~context:None loc env fun_t ty_expected_; fun_t @@ -3605,8 +3591,7 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l let case = List.hd cases in let param = name_pattern "param" cases in let exp_type = - instance env - (newgenty (Tarrow ({lbl = l; typ = ty_arg}, ty_res, Cok, arity))) + instance env (newgenty (Tarrow ({lbl = l; typ = ty_arg}, ty_res, arity))) in re { @@ -3824,13 +3809,9 @@ and type_application ~context total_app env funct (sargs : sargs) : let result_type omitted ty_fun = List.fold_left (fun ty_fun (l, ty, lv) -> - newty2 lv (Tarrow ({lbl = l; typ = ty}, ty_fun, Cok, None))) + newty2 lv (Tarrow ({lbl = l; typ = ty}, ty_fun, None))) ty_fun omitted in - let has_label l ty_fun = - let ls, tvar = list_labels env ty_fun in - tvar || List.mem l ls - in let ignored = ref [] in let force_tvar = let t = funct.exp_type in @@ -3842,7 +3823,7 @@ and type_application ~context total_app env funct (sargs : sargs) : if force_tvar then Some (List.length sargs) else match (expand_head env funct.exp_type).desc with - | Tarrow (_, _, _, Some arity) -> Some arity + | Tarrow (_, _, Some arity) -> Some arity | _ -> None in let force_uncurried_type funct = @@ -3896,8 +3877,8 @@ and type_application ~context total_app env funct (sargs : sargs) : if fully_applied then new_t else match new_t.desc with - | Tarrow (arg, ret, c, _) -> - {new_t with desc = Tarrow (arg, ret, c, Some newarity)} + | Tarrow (arg, ret, _) -> + {new_t with desc = Tarrow (arg, ret, Some newarity)} | _ -> new_t in (fully_applied, new_t) @@ -3917,7 +3898,7 @@ and type_application ~context total_app env funct (sargs : sargs) : in if List.length args < max_arity && total_app then match (expand_head env ty_fun).desc with - | Tarrow ({lbl; typ = t1}, t2, _, _) when is_optional lbl -> + | Tarrow ({lbl; typ = t1}, t2, _) when is_optional lbl -> ignored := (lbl, t1, ty_fun.level) :: !ignored; let arg = (lbl, Some (fun () -> option_none (instance env t1) Location.none)) @@ -3945,11 +3926,9 @@ and type_application ~context total_app env funct (sargs : sargs) : && not (is_identity_coercion funct.exp_desc) then Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; unify env ty_fun - (newty - (Tarrow - ({lbl = l1; typ = t1}, t2, Clink (ref Cunknown), top_arity))); + (newty (Tarrow ({lbl = l1; typ = t1}, t2, top_arity))); (t1, t2) - | Tarrow ({lbl = l; typ = t1}, t2, _, _) + | Tarrow ({lbl = l; typ = t1}, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> (t1, t2) | td -> ( @@ -3965,10 +3944,9 @@ and type_application ~context total_app env funct (sargs : sargs) : raise (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) - else if not (has_label l1 ty_fun) then + else raise (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) - else raise (Error (funct.exp_loc, env, Incoherent_label_order)) | _ -> raise (Error @@ -3988,10 +3966,9 @@ and type_application ~context total_app env funct (sargs : sargs) : let rec type_args ~context max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) ~top_arity = match (expand_head env ty_fun, expand_head env ty_fun0) with - | ( {desc = Tarrow ({lbl = l; typ = ty}, ty_fun, com, _); level = lv}, - {desc = Tarrow ({typ = ty0}, ty_fun0, _, _)} ) - when sargs <> [] && commu_repr com = Cok && List.length args < max_arity - -> + | ( {desc = Tarrow ({lbl = l; typ = ty}, ty_fun, _); level = lv}, + {desc = Tarrow ({typ = ty0}, ty_fun0, _)} ) + when sargs <> [] && List.length args < max_arity -> let name = label_name l and optional = is_optional l in let sargs, omitted, arg = match extract_label name sargs with @@ -4714,8 +4691,8 @@ let report_error env loc ppf error = | Expr_type_clash { trace = - (_, {desc = Tarrow (_, _, _, None)}) - :: (_, {desc = Tarrow (_, _, _, Some _)}) + (_, {desc = Tarrow (_, _, None)}) + :: (_, {desc = Tarrow (_, _, Some _)}) :: _; } -> fprintf ppf @@ -4724,8 +4701,8 @@ let report_error env loc ppf error = | Expr_type_clash { trace = - (_, {desc = Tarrow (_, _, _, Some arity_a)}) - :: (_, {desc = Tarrow (_, _, _, Some arity_b)}) + (_, {desc = Tarrow (_, _, Some arity_a)}) + :: (_, {desc = Tarrow (_, _, Some arity_b)}) :: _; } when arity_a <> arity_b -> @@ -4740,10 +4717,10 @@ let report_error env loc ppf error = | Apply_non_function typ -> ( (* modified *) match (repr typ).desc with - | Tarrow (_, return_type, _, _) -> + | Tarrow (_, return_type, _) -> let rec count_number_of_args count {Types.desc} = match desc with - | Tarrow (_, return_type, _, _) -> + | Tarrow (_, return_type, _) -> count_number_of_args (count + 1) return_type | _ -> count in @@ -4863,10 +4840,6 @@ let report_error env loc ppf error = fprintf ppf "Cannot create values of the private type %a" type_expr ty | Not_a_variant_type lid -> fprintf ppf "The type %a@ is not a variant type" longident lid - | Incoherent_label_order -> - fprintf ppf "This labeled function is applied to arguments@ "; - fprintf ppf "in an order different from other calls.@ "; - fprintf ppf "This is only allowed when the real type is known." | Less_general (kind, trace) -> (* modified *) super_report_unification_error ppf env trace @@ -4945,7 +4918,7 @@ let report_error env loc ppf error = *) let rec collect_args ?(acc = []) typ = match typ.desc with - | Tarrow (arg, next, _, _) -> collect_args ~acc:(arg.lbl :: acc) next + | Tarrow (arg, next, _) -> collect_args ~acc:(arg.lbl :: acc) next | _ -> acc in let args_from_type = collect_args typ in diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index c82b7d2f944..c9b69d216a4 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -96,7 +96,6 @@ type error = | Abstract_wrong_label of arg_label * type_expr | Scoping_let_module of string * type_expr | Not_a_variant_type of Longident.t - | Incoherent_label_order | Less_general of string * (type_expr * type_expr) list | Modules_not_allowed | Cannot_infer_signature diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 128b98b360a..fcf55459313 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1054,7 +1054,7 @@ let compute_variance env visited vari ty = visited := Type_map.add ty vari !visited; let compute_same = compute_variance_rec vari in match ty.desc with - | Tarrow (arg, ret, _, _) -> + | Tarrow (arg, ret, _) -> let open Variance in let v = conjugate vari in let v1 = @@ -1861,7 +1861,7 @@ let transl_exception env sext = let rec arity_from_arrow_type env core_type ty = match (core_type.ptyp_desc, (Ctype.repr ty).desc) with - | Ptyp_arrow {ret = ct2}, Tarrow (_, ret, _, _) -> + | Ptyp_arrow {ret = ct2}, Tarrow (_, ret, _) -> 1 + arity_from_arrow_type env ct2 ret | Ptyp_arrow _, _ | _, Tarrow _ -> assert false | _ -> 0 diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 7f2cfe72c76..f1d191f321e 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -93,7 +93,7 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = let is_function_type env ty = match scrape env ty with - | Tarrow (arg, rhs, _, _) -> Some (arg.typ, rhs) + | Tarrow (arg, rhs, _) -> Some (arg.typ, rhs) | _ -> None let is_base_type env ty base_ty_path = diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index c6b26198039..caddb8ebb33 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -25,7 +25,7 @@ and arg = {lbl: arg_label; typ: type_expr} and type_desc = | Tvar of string option - | Tarrow of arg * type_expr * commutable * arity + | Tarrow of arg * type_expr * arity | Ttuple of type_expr list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref @@ -61,8 +61,6 @@ and abbrev_memo = and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent -and commutable = Cok | Cunknown | Clink of commutable ref - module Type_ops = struct type t = type_expr let compare t1 t2 = t1.id - t2.id diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 2ceef397d29..36386aacc85 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -63,12 +63,10 @@ and type_desc = | Tvar of string option (** [Tvar (Some "a")] ==> ['a] or ['_a] [Tvar None] ==> [_] *) - | Tarrow of arg * type_expr * commutable * arity - (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] - [Tarrow (Labelled {txt="l"}, e1, e2, c)] ==> [l:e1 -> e2] - [Tarrow (Optional {txt="l"}, e1, e2, c)] ==> [?l:e1 -> e2] - - See [commutable] for the last argument. *) + | Tarrow of arg * type_expr * arity + (** [Tarrow (Nolabel, e1, e2)] ==> [e1 -> e2] + [Tarrow (Labelled {txt="l"}, e1, e2)] ==> [l:e1 -> e2] + [Tarrow (Optional {txt="l"}, e1, e2)] ==> [?l:e1 -> e2] *) | Ttuple of type_expr list (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) | Tconstr of Path.t * type_expr list * abbrev_memo ref (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] @@ -181,29 +179,6 @@ and abbrev_memo = and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent -(** [commutable] is a flag appended to every arrow type. - - When typing an application, if the type of the functional is - known, its type is instantiated with [Cok] arrows, otherwise as - [Clink (ref Cunknown)]. - - When the type is not known, the application will be used to infer - the actual type. This is fragile in presence of labels where - there is no principal type. - - Two incompatible applications relying on [Cunknown] arrows will - trigger an error. - - let f g = - g ~a:() ~b:(); - g ~b:() ~a:(); - - Error: This function is applied to arguments - in an order different from other calls. - This is only allowed when the real type is known. -*) -and commutable = Cok | Cunknown | Clink of commutable ref - module Type_ops : sig type t = type_expr val compare : t -> t -> int diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index d188a3b0b9f..f47c1f554c2 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -314,7 +314,7 @@ and transl_type_aux env policy styp = newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) else ty1 in - let ty = newty (Tarrow ({lbl; typ = ty1}, cty2.ctyp_type, Cok, arity)) in + let ty = newty (Tarrow ({lbl; typ = ty1}, cty2.ctyp_type, arity)) in ctyp (Ttyp_arrow ({attrs = arg.attrs; lbl; typ = cty1}, cty2, arity)) ty | Ptyp_tuple stl -> assert (List.length stl >= 2); diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 36595660b69..7af547fd113 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -159,11 +159,6 @@ completely dead and have been retained as named variants: `check_value_name` during definition; `let \"->" = 1` is rejected with a clean diagnostic (`illegal_value_name.res`). The parser does **not** reject `\"->"`. -- `typecore.Incoherent_label_order` — live: a not-yet-generalized - function value applied more than once with labelled arguments in - conflicting orders (`let f = g => (g(~a=1, ~b=2), g(~b=3, ~a=4))`) hits - the leftover/tvar path in `type_unknown_args` after the first call fixes - the arrow order (`labeled_args_incoherent_order.res`). - `typedecl.Type_clash` — retained but **appears dead**: its only raise site (`update_type`) unifies `t` against `t`'s own manifest — a type against an alpha-renamed copy of itself — which cannot @@ -218,7 +213,6 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Abstract_wrong_label` | ✓ | `abstract_wrong_label.res` | Multi-arg function literal where an inner argument label doesn't match the expected arrow's label (e.g. `let f: (~a, ~b) => int = (~a, ~c) => …`). | | `Scoping_let_module` | ✓ | `scoping_let_module.res` | | | `Not_a_variant_type` | ✓ | `variant_spread_pattern_not_a_variant.res` | Pattern-level variant spread of a non-variant type. | -| `Incoherent_label_order` | ✓ | `labeled_args_incoherent_order.res` | A not-yet-generalized function value applied more than once with labelled args in conflicting orders (`g => (g(~a, ~b), g(~b, ~a))`); the reordered second call hits the leftover/tvar path in `type_unknown_args`. | | `Less_general` | ✓ | `less_general_universal.res` | | | `Modules_not_allowed` | ✓ | `super_errors_multi/Modules_not_allowed_toplevel` | Toplevel `let module(M) = …` pattern with `allow_modules=false`. | | `Cannot_infer_signature` | ✓ | `cannot_infer_signature.res` | | diff --git a/tests/build_tests/super_errors/expected/labeled_args_incoherent_order.res.expected b/tests/build_tests/super_errors/expected/labeled_args_incoherent_order.res.expected deleted file mode 100644 index a7b057c2156..00000000000 --- a/tests/build_tests/super_errors/expected/labeled_args_incoherent_order.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/labeled_args_incoherent_order.res:1:30 - - 1 │ let f = g => (g(~a=1, ~b=2), g(~b=3, ~a=4)) - 2 │ - - This labeled function is applied to arguments -in an order different from other calls. -This is only allowed when the real type is known. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/labeled_args_incoherent_order.res b/tests/build_tests/super_errors/fixtures/labeled_args_incoherent_order.res deleted file mode 100644 index 76d09d7fc49..00000000000 --- a/tests/build_tests/super_errors/fixtures/labeled_args_incoherent_order.res +++ /dev/null @@ -1 +0,0 @@ -let f = g => (g(~a=1, ~b=2), g(~b=3, ~a=4)) diff --git a/tests/tests/src/label_uncurry.mjs b/tests/tests/src/label_uncurry.mjs index d98de74dceb..3566a35c630 100644 --- a/tests/tests/src/label_uncurry.mjs +++ b/tests/tests/src/label_uncurry.mjs @@ -18,6 +18,13 @@ function u1(f) { console.log(f(2, "x")); } +function inferredOrder(g) { + return [ + g(1, 2), + g(4, 3) + ]; +} + function h(x) { return 3; } @@ -28,6 +35,7 @@ export { f, u, u1, + inferredOrder, h, a, } diff --git a/tests/tests/src/label_uncurry.res b/tests/tests/src/label_uncurry.res index ae8012ed749..31f14ca885e 100644 --- a/tests/tests/src/label_uncurry.res +++ b/tests/tests/src/label_uncurry.res @@ -14,6 +14,9 @@ let u1 = (f: u) => { f(~y="x", ~x=2)->Console.log f(~x=2, ~y="x")->Console.log } + +let inferredOrder = g => (g(~a=1, ~b=2), g(~b=3, ~a=4)) + let h = (~x: unit) => 3 let a = u1(u) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 57dfb587def..886f8c33caf 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -350,7 +350,7 @@ let value_detail (typ : Types.type_expr) = collect_signature_types t) in [{path = p; generic_parameters = ts}]) - | Tarrow (arg, ret, _, _) -> + | Tarrow (arg, ret, _) -> collect_signature_types arg.typ @ collect_signature_types ret | Tvar None -> [{path = "_"; generic_parameters = []}] | _ -> []