From 1637911462d98eb5f20a93f86dfaec5aa69e4944 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 May 2025 18:50:28 +0200 Subject: [PATCH 01/17] refactor --- compiler/ml/error_message_utils.ml | 21 +- compiler/ml/typecore.ml | 371 ++++++++++-------- compiler/ml/typecore.mli | 20 +- compiler/ml/typemod.ml | 8 +- .../function_return_mismatch.res.expected | 12 +- .../switch_different_types.res.expected | 3 +- .../expected/try_catch_same_type.res.expected | 16 + .../fixtures/function_return_mismatch.res | 2 + .../fixtures/try_catch_same_type.res | 3 + 9 files changed, 266 insertions(+), 190 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/try_catch_same_type.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/try_catch_same_type.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 267ac6c0f6..ad858261dd 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -76,7 +76,8 @@ type type_clash_context = | MaybeUnwrapOption | IfCondition | IfReturn - | Switch + | SwitchReturn + | TryReturn | StringConcat | ComparisonOperator | MathOperator of { @@ -107,7 +108,8 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But this function argument is expecting:" | Some ComparisonOperator -> fprintf ppf "But it's being compared to something of type:" - | Some Switch -> fprintf ppf "But this switch is expected to return:" + | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:" + | Some TryReturn -> fprintf ppf "But this try/catch is expected to return:" | Some IfCondition -> fprintf ppf "But @{if@} conditions must always be of type:" | Some IfReturn -> @@ -121,7 +123,8 @@ let error_expected_type_text ppf type_clash_context = "But it's being used with the @{%s@} operator, which works on:" operator | Some StringConcat -> fprintf ppf "But string concatenation is expecting:" - | _ -> fprintf ppf "But it's expected to have type:" + | Some MaybeUnwrapOption | None -> + fprintf ppf "But it's expected to have type:" let is_record_type ~extract_concrete_typedecl ~env ty = try @@ -201,11 +204,17 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf (if for_float then "int" else "float") | _ -> ()) | _ -> ()) - | Some Switch, _ -> + | Some SwitchReturn, _ -> fprintf ppf "\n\n\ - \ All branches in a @{switch@} must return the same type. To fix \ - this, change your branch to return the expected type." + \ All branches in a @{switch@} must return the same type.@,\ + To fix this, change your branch to return the expected type." + | Some TryReturn, _ -> + fprintf ppf + "\n\n\ + \ The @{try@} body and the @{catch@} block must return the \ + same type.@,\ + To fix this, change your try/catch blocks to return the expected type." | Some IfCondition, _ -> fprintf ppf "\n\n\ diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 5e1f411f90..43c0e53f60 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -32,7 +32,10 @@ type error = | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * type_clash_context option + | Expr_type_clash of { + trace: (type_expr * type_expr) list; + context: type_clash_context option; + } | Apply_non_function of type_expr | Apply_wrong_label of Noloc.arg_label * type_expr | Label_multiply_defined of { @@ -308,10 +311,9 @@ let unify_pat_types loc env ty ty' = raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) (* unification inside type_exp and type_expect *) -let unify_exp_types ?type_clash_context loc env ty expected_ty = +let unify_exp_types ~context loc env ty expected_ty = try unify env ty expected_ty with - | Unify trace -> - raise (Error (loc, env, Expr_type_clash (trace, type_clash_context))) + | Unify trace -> raise (Error (loc, env, Expr_type_clash {trace; context})) | Tags (l1, l2) -> raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) @@ -729,7 +731,7 @@ let rec collect_missing_arguments env type1 type2 = | None -> None) | _ -> None -let print_expr_type_clash ?type_clash_context env loc trace ppf = +let print_expr_type_clash ~context env loc trace ppf = (* this is the most frequent error. We should do whatever we can to provide specific guidance to this generic error before giving up *) let bottom_aliases_result = bottom_aliases trace in @@ -784,10 +786,10 @@ let print_expr_type_clash ?type_clash_context env loc trace ppf = Printtyp.super_report_unification_error ppf env trace (function - | ppf -> error_type_text ppf type_clash_context) - (function ppf -> error_expected_type_text ppf type_clash_context); + | ppf -> error_type_text ppf context) + (function ppf -> error_expected_type_text ppf context); print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf - bottom_aliases_result type_clash_context; + bottom_aliases_result context; show_extra_help ppf env trace let report_arity_mismatch ~arity_a ~arity_b ppf = @@ -1885,6 +1887,7 @@ let rec approx_type env sty = | Ptyp_poly (_, sty) -> approx_type env sty | _ -> newvar () +(* TODO: Needs type clash context? *) let rec type_approx env sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) -> type_approx env e @@ -1902,7 +1905,8 @@ let rec type_approx env sexp = let ty1 = approx_type env sty in (try unify env ty ty1 with Unify trace -> - raise (Error (sexp.pexp_loc, env, Expr_type_clash (trace, None)))); + raise + (Error (sexp.pexp_loc, env, Expr_type_clash {trace; context = None}))); ty1 | Pexp_coerce (e, (), sty2) -> let approx_ty_opt = function @@ -1914,7 +1918,8 @@ let rec type_approx env sexp = and ty2 = approx_type env sty2 in (try unify env ty ty1 with Unify trace -> - raise (Error (sexp.pexp_loc, env, Expr_type_clash (trace, None)))); + raise + (Error (sexp.pexp_loc, env, Expr_type_clash {trace; context = None}))); ty2 | _ -> newvar () @@ -2179,9 +2184,9 @@ let rec name_pattern default = function (* Typing of expressions *) -let unify_exp ?type_clash_context env exp expected_ty = +let unify_exp ~context env exp expected_ty = let loc = proper_exp_loc exp in - unify_exp_types ?type_clash_context loc env exp.exp_type expected_ty + unify_exp_types ~context loc env exp.exp_type expected_ty let is_ignore ~env ~arity funct = match funct.exp_desc with @@ -2217,9 +2222,9 @@ type lazy_args = (Asttypes.Noloc.arg_label * (unit -> Typedtree.expression) option) list type targs = (Asttypes.Noloc.arg_label * Typedtree.expression option) list -let rec type_exp ?recarg env sexp = +let rec type_exp ~context ?recarg env sexp = (* We now delegate everything to type_expect *) - type_expect ?recarg env sexp (newvar ()) + type_expect ~context ?recarg env sexp (newvar ()) (* Typing of an expression with an expected type. This provide better error messages, and allows controlled @@ -2227,23 +2232,22 @@ let rec type_exp ?recarg env sexp = In the principal case, [type_expected'] may be at generic_level. *) -and type_expect ?type_clash_context ?in_function ?recarg env sexp ty_expected = +and type_expect ~context ?in_function ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in let exp = Builtin_attributes.warning_scope sexp.pexp_attributes (fun () -> - type_expect_ ?type_clash_context ?in_function ?recarg env sexp - ty_expected) + type_expect_ ~context ?in_function ?recarg env sexp ty_expected) in Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp - ty_expected = +and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected + = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = - unify_exp ?type_clash_context env (re exp) (instance env ty_expected); + unify_exp ~context env (re exp) (instance env ty_expected); exp in let process_optional_label (id, ld, e, opt) = @@ -2302,7 +2306,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp sbody ) when contains_gadt env spat -> (* TODO: allow non-empty attributes? *) - type_expect ?in_function env + type_expect ~context:None ?in_function env { sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody]); @@ -2316,9 +2320,11 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) in let pat_exp_list, new_env, unpacks = - type_let env rec_flag spat_sexp_list scp true + type_let ~context:None env rec_flag spat_sexp_list scp true + in + let body = + type_expect ~context:None new_env (wrap_unpacks sbody unpacks) ty_expected in - let body = type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in let () = if rec_flag = Recursive then Rec_check.check_recursive_bindings pat_exp_list @@ -2379,30 +2385,30 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp [Vb.mk spat smatch] sbody in - type_function ?in_function ~arity ~async loc sexp.pexp_attributes env - ty_expected l + type_function ~context:None ?in_function ~arity ~async loc + sexp.pexp_attributes env ty_expected l [Exp.case pat body] | Pexp_fun {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} -> let l = Asttypes.to_noloc l in - type_function ?in_function ~arity ~async loc sexp.pexp_attributes env - ty_expected l + type_function ~context:None ?in_function ~arity ~async loc + sexp.pexp_attributes env ty_expected l [Ast_helper.Exp.case spat sbody] | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> assert (sargs <> []); begin_def (); (* one more level for non-returning functions *) - let funct = type_exp env sfunct in + let funct = type_exp ~context:None env sfunct in let ty = instance env funct.exp_type in end_def (); wrap_trace_gadt_instances env (lower_args env []) ty; begin_def (); let total_app = not partial in - let type_clash_context = type_clash_context_from_function sexp sfunct in + let context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = - match translate_unified_ops env funct sargs with + match translate_unified_ops ~context:None env funct sargs with | Some (targs, result_type) -> (targs, result_type, true) - | None -> type_application ?type_clash_context total_app env funct sargs + | None -> type_application ~context total_app env funct sargs in end_def (); unify_var env (newvar ()) funct.exp_type; @@ -2429,7 +2435,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp else rue (mk_apply funct args) | Pexp_match (sarg, caselist) -> begin_def (); - let arg = type_exp env sarg in + let arg = type_exp ~context:None env sarg in end_def (); if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type; generalize arg.exp_type; @@ -2446,12 +2452,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp empty pattern matching can be generated by Camlp4 with its revised syntax. Let's accept it for backward compatibility. *) let val_cases, partial = - type_cases ~root_type_clash_context:Switch env arg.exp_type ty_expected - true loc val_caselist + type_cases ~call_context:`Switch env arg.exp_type ty_expected true loc + val_caselist in let exn_cases, _ = - type_cases ~root_type_clash_context:Switch env Predef.type_exn ty_expected - false loc exn_caselist + type_cases ~call_context:`Switch env Predef.type_exn ty_expected false loc + exn_caselist in re { @@ -2463,9 +2469,10 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_try (sbody, caselist) -> - let body = type_expect env sbody ty_expected in + let body = type_expect ~context:None env sbody ty_expected in let cases, _ = - type_cases env Predef.type_exn ty_expected false loc caselist + type_cases ~call_context:`Try env Predef.type_exn ty_expected false loc + caselist in re { @@ -2480,9 +2487,11 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp assert (List.length sexpl >= 2); let subtypes = List.map (fun _ -> newgenvar ()) sexpl in let to_unify = newgenty (Ttuple subtypes) in - unify_exp_types loc env to_unify ty_expected; + unify_exp_types ~context:None loc env to_unify ty_expected; let expl = - List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes + List.map2 + (fun body ty -> type_expect ~context:None env body ty) + sexpl subtypes in re { @@ -2495,7 +2504,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_construct (lid, sarg) -> - type_construct env loc lid sarg ty_expected sexp.pexp_attributes + type_construct ~context:None env loc lid sarg ty_expected + sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( (* Keep sharing *) let ty_expected0 = instance env ty_expected in @@ -2510,7 +2520,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp row_field_repr (List.assoc l row0.row_fields) ) with | Rpresent (Some ty), Rpresent (Some ty0) -> - let arg = type_argument env sarg ty ty0 in + let arg = type_argument ~context env sarg ty ty0 in re { exp_desc = Texp_variant (l, Some arg); @@ -2523,7 +2533,11 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | _ -> raise Not_found) | _ -> raise Not_found with Not_found -> - let arg = may_map (type_exp env) sarg in + let arg = + may_map + (fun sarg -> type_expect ~context:None env sarg (newvar ())) + sarg + in let arg_type = may_map (fun arg -> arg.exp_type) arg in rue { @@ -2563,11 +2577,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp (type_record_elem_list loc true env (fun e k -> k - (type_label_exp true env loc ty_record (process_optional_label e))) + (type_label_exp ~context:None true env loc ty_record + (process_optional_label e))) opath lid_sexp_list) (fun x -> x) in - unify_exp_types loc env ty_record (instance env ty_expected); + unify_exp_types ~context:None loc env ty_record (instance env ty_expected); check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; let label_descriptions, representation = match (lbl_exp_list, repr_opt) with @@ -2640,7 +2655,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } | Pexp_record (lid_sexp_list, Some sexp) -> assert (lid_sexp_list <> []); - let exp = type_exp ~recarg env sexp in + let exp = type_expect ~context:None ~recarg env sexp (newvar ()) in let ty_record, opath = let get_path ty = try @@ -2672,11 +2687,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp (type_record_elem_list loc closed env (fun e k -> k - (type_label_exp true env loc ty_record (process_optional_label e))) + (type_label_exp ~context:None true env loc ty_record + (process_optional_label e))) opath lid_sexp_list) (fun x -> x) in - unify_exp_types loc env ty_record (instance env ty_expected); + unify_exp_types ~context:None loc env ty_record (instance env ty_expected); check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; let opt_exp, label_definitions = let _lid, lbl, _lbl_exp, _opt = List.hd lbl_exp_list in @@ -2688,15 +2704,16 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let ty_exp = instance env exp.exp_type in let unify_kept lbl = let _, ty_arg1, ty_res1 = instance_label false lbl in - unify_exp_types exp.exp_loc env ty_exp ty_res1; + unify_exp_types ~context:None exp.exp_loc env ty_exp ty_res1; match matching_label lbl with | lid, _lbl, lbl_exp, _ -> (* do not connect result types for overridden labels *) Overridden (lid, lbl_exp) | exception Not_found -> let _, ty_arg2, ty_res2 = instance_label false lbl in - unify_exp_types loc env ty_arg1 ty_arg2; - unify_exp_types loc env (instance env ty_expected) ty_res2; + unify_exp_types ~context:None loc env ty_arg1 ty_arg2; + unify_exp_types ~context:None loc env (instance env ty_expected) + ty_res2; Kept ty_arg1 in let label_definitions = Array.map unify_kept lbl.lbl_all in @@ -2733,9 +2750,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_field (srecord, lid) -> - let record, label, _ = type_label_access env srecord lid in + let record, label, _ = type_label_access ~context:None env srecord lid in let _, ty_arg, ty_res = instance_label false label in - unify_exp env record ty_res; + unify_exp ~context:None env record ty_res; rue { exp_desc = Texp_field (record, lid, label); @@ -2746,13 +2763,15 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_setfield (srecord, lid, snewval) -> - let record, label, opath = type_label_access env srecord lid in + let record, label, opath = + type_label_access ~context:None env srecord lid + in let ty_record = if opath = None then newvar () else record.exp_type in let label_loc, label, newval, _ = - type_label_exp ~type_clash_context:SetRecordField false env loc ty_record + type_label_exp ~context:(Some SetRecordField) false env loc ty_record (lid, label, snewval, false) in - unify_exp env record ty_record; + unify_exp ~context:None env record ty_record; if label.lbl_mut = Immutable then raise (Error (loc, env, Label_not_mutable lid.txt)); Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes @@ -2769,10 +2788,10 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | Pexp_array sargl -> let ty = newgenvar () in let to_unify = Predef.type_array ty in - unify_exp_types loc env to_unify ty_expected; + unify_exp_types ~context:None loc env to_unify ty_expected; let argl = List.map - (fun sarg -> type_expect ~type_clash_context:ArrayValue env sarg ty) + (fun sarg -> type_expect ~context:(Some ArrayValue) env sarg ty) sargl in re @@ -2786,12 +2805,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } | Pexp_ifthenelse (scond, sifso, sifnot) -> ( let cond = - type_expect ~type_clash_context:IfCondition env scond Predef.type_bool + type_expect ~context:(Some IfCondition) env scond Predef.type_bool in match sifnot with | None -> let ifso = - type_expect ~type_clash_context:IfReturn env sifso Predef.type_unit + type_expect ~context:(Some IfReturn) env sifso Predef.type_unit in rue { @@ -2803,14 +2822,10 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Some sifnot -> - let ifso = - type_expect ~type_clash_context:IfReturn env sifso ty_expected - in - let ifnot = - type_expect ~type_clash_context:IfReturn env sifnot ty_expected - in + let ifso = type_expect ~context:(Some IfReturn) env sifso ty_expected in + let ifnot = type_expect ~context:(Some IfReturn) env sifnot ty_expected in (* Keep sharing *) - unify_exp ~type_clash_context:IfReturn env ifnot ifso.exp_type; + unify_exp ~context:(Some IfReturn) env ifnot ifso.exp_type; re { exp_desc = Texp_ifthenelse (cond, ifso, Some ifnot); @@ -2821,8 +2836,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; }) | Pexp_sequence (sexp1, sexp2) -> - let exp1 = type_statement env sexp1 in - let exp2 = type_expect env sexp2 ty_expected in + let exp1 = type_statement ~context:None env sexp1 in + let exp2 = type_expect ~context env sexp2 ty_expected in re { exp_desc = Texp_sequence (exp1, exp2); @@ -2833,8 +2848,11 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_while (scond, sbody) -> - let cond = type_expect env scond Predef.type_bool in - let body = type_statement env sbody in + let cond = + (* TODO: Add explicit WhileCondition *) + type_expect ~context:(Some IfCondition) env scond Predef.type_bool + in + let body = type_statement ~context:None env sbody in rue { exp_desc = Texp_while (cond, body); @@ -2845,8 +2863,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_for (param, slow, shigh, dir, sbody) -> - let low = type_expect env slow Predef.type_int in - let high = type_expect env shigh Predef.type_int in + (* TODO: Add explicit ForCondition *) + let low = type_expect ~context:None env slow Predef.type_int in + let high = type_expect ~context:None env shigh Predef.type_int in let id, new_env = match param.ppat_desc with | Ppat_any -> (Ident.create "_for", env) @@ -2862,7 +2881,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp ~check:(fun s -> Warnings.Unused_for_index s) | _ -> raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) in - let body = type_statement new_env sbody in + let body = type_statement ~context:None new_env sbody in rue { exp_desc = Texp_for (id, param, low, high, dir, body); @@ -2882,8 +2901,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp if separate then ( end_def (); generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty)) - else (type_argument env sarg ty ty, ty) + ( type_argument ~context:None env sarg ty (instance env ty), + instance env ty )) + else (type_argument ~context:None env sarg ty ty, ty) in rue { @@ -2904,7 +2924,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let cty', force = Typetexp.transl_simple_type_delayed env sty' in let ty' = cty'.ctyp_type in if separate then begin_def (); - let arg = type_exp env sarg in + (* TODO: What should this be?*) + let type_clash_context = None in + let arg = type_exp ~context env sarg in let gen = if separate then ( end_def (); @@ -2914,7 +2936,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp with Unify trace -> raise (Error - (arg.exp_loc, env, Expr_type_clash (trace, type_clash_context)))); + ( arg.exp_loc, + env, + Expr_type_clash {trace; context = type_clash_context} ))); gen) else true in @@ -2953,7 +2977,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp (Texp_coerce cty', loc, sexp.pexp_attributes) :: arg.exp_extra; } | Pexp_send (e, {txt = met}) -> ( - let obj = type_exp env e in + let obj = type_exp ~context:None env e in let obj_meths = ref None in try let meth, exp, typ = @@ -3010,7 +3034,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let id, new_env = Env.enter_module name.txt modl.mod_type env in Ctype.init_def (Ident.current_time ()); Typetexp.widen context; - let body = type_expect new_env sbody ty_expected in + let body = type_expect ~context:None new_env sbody ty_expected in (* go back to original level *) end_def (); (* Unification of body.exp_type with the fresh variable ty @@ -3035,7 +3059,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } | Pexp_letexception (cd, sbody) -> let cd, newenv = Typedecl.transl_exception env cd in - let body = type_expect newenv sbody ty_expected in + let body = type_expect ~context:None newenv sbody ty_expected in re { exp_desc = Texp_letexception (cd, body); @@ -3046,7 +3070,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_assert e -> - let cond = type_expect env e Predef.type_bool in + (* TODO: Add explicit AssertCondition *) + let cond = type_expect ~context:(Some IfCondition) env e Predef.type_bool in let exp_type = match cond.exp_desc with | Texp_construct (_, {cstr_name = "false"}, _) -> instance env ty_expected @@ -3087,7 +3112,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let id, new_env = Env.enter_type name decl env in Ctype.init_def (Ident.current_time ()); - let body = type_exp new_env sbody in + let body = type_exp ~context:None new_env sbody in (* Replace every instance of this type constructor in the resulting type. *) let seen = Hashtbl.create 8 in @@ -3136,7 +3161,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } | Pexp_open (ovf, lid, e) -> let path, newenv = !type_open ovf env sexp.pexp_loc lid in - let exp = type_expect newenv e ty_expected in + let exp = type_expect ~context:None newenv e ty_expected in { exp with exp_extra = @@ -3175,8 +3200,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | Pexp_jsx_element _ -> failwith "Pexp_jsx_element is expected to be transformed at this point" -and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l - caselist = +and type_function ~context ?in_function ~arity ~async loc attrs env ty_expected_ + l caselist = let state = Warnings.backup () in (* Disable Unerasable_optional_argument for uncurried functions *) let unerasable_optional_argument = @@ -3188,7 +3213,7 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l | None -> ty_expected_ | Some arity -> let fun_t = newty (Tarrow (l, newvar (), newvar (), Cok, Some arity)) in - unify_exp_types loc env fun_t ty_expected_; + unify_exp_types ~context loc env fun_t ty_expected_; fun_t in let loc_fun, ty_fun = @@ -3220,8 +3245,8 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l generalize_structure ty_arg; generalize_structure ty_res); let cases, partial = - type_cases ~in_function:(loc_fun, ty_fun) env ty_arg ty_res true loc - caselist + type_cases ~call_context:`Function ~in_function:(loc_fun, ty_fun) env ty_arg + ty_res true loc caselist in let case = List.hd cases in if is_optional l && not_function env ty_res then @@ -3243,8 +3268,8 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l exp_env = env; } -and type_label_access env srecord lid = - let record = type_exp ~recarg:Allowed env srecord in +and type_label_access ~context env srecord lid = + let record = type_exp ~context ~recarg:Allowed env srecord in let ty_exp = record.exp_type in let opath = try @@ -3272,8 +3297,7 @@ and type_label_access env srecord lid = (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) -and type_label_exp ?type_clash_context create env loc ty_expected - (lid, label, sarg, opt) = +and type_label_exp ~context create env loc ty_expected (lid, label, sarg, opt) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = Env.has_local_constraints env in @@ -3300,9 +3324,7 @@ and type_label_exp ?type_clash_context create env loc ty_expected else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = - type_argument ?type_clash_context env sarg ty_arg (instance env ty_arg) - in + let arg = type_argument ~context env sarg ty_arg (instance env ty_arg) in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; @@ -3312,10 +3334,10 @@ and type_label_exp ?type_clash_context create env loc ty_expected (* Try to retype without propagating ty_arg, cf PR#4862 *) may Btype.backtrack snap; begin_def (); - let arg = type_exp env sarg in + let arg = type_exp ~context env sarg in end_def (); generalize_expansive env arg.exp_type; - unify_exp env arg ty_arg; + unify_exp ~context env arg ty_arg; check_univars env false "field value" arg label.lbl_arg vars; arg with @@ -3324,23 +3346,23 @@ and type_label_exp ?type_clash_context create env loc ty_expected in (lid, label, {arg with exp_type = instance env arg.exp_type}, opt) -and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected - = - let texp = type_expect ?type_clash_context ?recarg env sarg ty_expected' in - unify_exp ?type_clash_context env texp ty_expected; +and type_argument ~context ?recarg env sarg ty_expected' ty_expected = + let texp = type_expect ~context ?recarg env sarg ty_expected' in + unify_exp ~context env texp ty_expected; texp (** This is ad-hoc translation for unifying specific primitive operations See [Unified_ops] module for detailed explanation. *) -and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) +and translate_unified_ops ~context (env : Env.t) (funct : Typedtree.expression) (sargs : sargs) : (targs * Types.type_expr) option = + ignore context; match funct.exp_desc with | Texp_ident (path, _, _) -> ( let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in match (entry, sargs) with | Some {form = Unary; specialization}, [(lhs_label, lhs_expr)] -> - let lhs = type_exp env lhs_expr in + let lhs = type_exp ~context:None env lhs_expr in let lhs_type = expand_head env lhs.exp_type in let result_type = match (lhs_type.desc, specialization) with @@ -3366,58 +3388,64 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) Some (targs, result_type) | ( Some {form = Binary; specialization}, [(lhs_label, lhs_expr); (rhs_label, rhs_expr)] ) -> - let lhs = type_exp env lhs_expr in + let lhs = type_exp ~context:None env lhs_expr in let lhs_type = expand_head env lhs.exp_type in - let rhs = type_exp env rhs_expr in + let rhs = type_exp ~context:None env rhs_expr in let rhs_type = expand_head env rhs.exp_type in let lhs, rhs, result_type = (* Rule 1. Try unifying to lhs *) match (lhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> - let rhs = type_expect env rhs_expr Predef.type_int in + let rhs = type_expect ~context:None env rhs_expr Predef.type_int in (lhs, rhs, instance_def Predef.type_int) | Tconstr (path, _, _), {bool = Some _} when Path.same path Predef.path_bool -> - let rhs = type_expect env rhs_expr Predef.type_bool in + let rhs = type_expect ~context:None env rhs_expr Predef.type_bool in (lhs, rhs, instance_def Predef.type_bool) | Tconstr (path, _, _), {float = Some _} when Path.same path Predef.path_float -> - let rhs = type_expect env rhs_expr Predef.type_float in + let rhs = type_expect ~context:None env rhs_expr Predef.type_float in (lhs, rhs, instance_def Predef.type_float) | Tconstr (path, _, _), {bigint = Some _} when Path.same path Predef.path_bigint -> - let rhs = type_expect env rhs_expr Predef.type_bigint in + let rhs = type_expect ~context:None env rhs_expr Predef.type_bigint in (lhs, rhs, instance_def Predef.type_bigint) | Tconstr (path, _, _), {string = Some _} when Path.same path Predef.path_string -> - let rhs = type_expect env rhs_expr Predef.type_string in + let rhs = type_expect ~context:None env rhs_expr Predef.type_string in (lhs, rhs, instance_def Predef.type_string) | _ -> ( (* Rule 2. Try unifying to rhs *) match (rhs_type.desc, specialization) with | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> - let lhs = type_expect env lhs_expr Predef.type_int in + let lhs = type_expect ~context:None env lhs_expr Predef.type_int in (lhs, rhs, instance_def Predef.type_int) | Tconstr (path, _, _), {bool = Some _} when Path.same path Predef.path_bool -> - let lhs = type_expect env lhs_expr Predef.type_bool in + let lhs = type_expect ~context:None env lhs_expr Predef.type_bool in (lhs, rhs, instance_def Predef.type_bool) | Tconstr (path, _, _), {float = Some _} when Path.same path Predef.path_float -> - let lhs = type_expect env lhs_expr Predef.type_float in + let lhs = + type_expect ~context:None env lhs_expr Predef.type_float + in (lhs, rhs, instance_def Predef.type_float) | Tconstr (path, _, _), {bigint = Some _} when Path.same path Predef.path_bigint -> - let lhs = type_expect env lhs_expr Predef.type_bigint in + let lhs = + type_expect ~context:None env lhs_expr Predef.type_bigint + in (lhs, rhs, instance_def Predef.type_bigint) | Tconstr (path, _, _), {string = Some _} when Path.same path Predef.path_string -> - let lhs = type_expect env lhs_expr Predef.type_string in + let lhs = + type_expect ~context:None env lhs_expr Predef.type_string + in (lhs, rhs, instance_def Predef.type_string) | _ -> (* Rule 3. Fallback to int *) - let lhs = type_expect env lhs_expr Predef.type_int in - let rhs = type_expect env rhs_expr Predef.type_int in + let lhs = type_expect ~context:None env lhs_expr Predef.type_int in + let rhs = type_expect ~context:None env rhs_expr Predef.type_int in (lhs, rhs, instance_def Predef.type_int)) in let targs = @@ -3427,7 +3455,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) | _ -> None) | _ -> None -and type_application ?type_clash_context total_app env funct (sargs : sargs) : +and type_application ~context total_app env funct (sargs : sargs) : targs * Types.type_expr * bool = let result_type omitted ty_fun = List.fold_left @@ -3578,14 +3606,14 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : in let optional = is_optional l1 in let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then unify_exp env arg1 (type_option (newvar ())); + let arg1 = type_expect ~context env sarg1 ty1 in + if optional then unify_exp ~context env arg1 (type_option (newvar ())); arg1 in type_unknown_args max_arity ~args:((l1, Some arg1) :: args) ~top_arity:None omitted ty2 sargl in - let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 + 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 (l, ty, ty_fun, com, _); level = lv}, @@ -3611,18 +3639,17 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : Some (if (not optional) || is_optional_loc l' then fun () -> type_argument - ?type_clash_context: - (type_clash_context_for_function_argument - type_clash_context sarg0) + ~context: + (type_clash_context_for_function_argument context sarg0) env sarg0 ty ty0 else fun () -> option_some - (type_argument ?type_clash_context env sarg0 + (type_argument ~context env sarg0 (extract_option_type env ty) (extract_option_type env ty0))) ) in - type_args ?type_clash_context max_arity ((l, arg) :: args) omitted ~ty_fun - ty_fun0 ~sargs ~top_arity + type_args ~context max_arity ((l, arg) :: args) omitted ~ty_fun ty_fun0 + ~sargs ~top_arity | _ -> type_unknown_args max_arity ~args ~top_arity omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) @@ -3636,7 +3663,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : let ty_arg, ty_res = filter_arrow ~env ~arity:top_arity (instance env funct.exp_type) Nolabel in - let exp = type_expect env sarg ty_arg in + let exp = type_expect ~context env sarg ty_arg in (match (expand_head env exp.exp_type).desc with | Tarrow _ when not total_app -> Location.prerr_warning exp.exp_loc Warnings.Partial_application @@ -3647,7 +3674,7 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : ([(Nolabel, Some exp)], ty_res, false) | _ -> let targs, ret_t = - type_args ?type_clash_context max_arity [] [] ~ty_fun:funct.exp_type + type_args ~context max_arity [] [] ~ty_fun:funct.exp_type (instance env funct.exp_type) ~sargs ~top_arity in @@ -3658,7 +3685,9 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) : in (targs, ret_t, fully_applied) -and type_construct env loc lid sarg ty_expected attrs = +and type_construct ~context env loc lid sarg ty_expected attrs = + (* TODO: Fix this *) + ignore context; let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -3705,11 +3734,11 @@ and type_construct env loc lid sarg ty_expected attrs = exp_env = env; } in - let type_clash_context = type_clash_context_maybe_option ty_expected ty_res in + let context = type_clash_context_maybe_option ty_expected ty_res in if separate then ( end_def (); generalize_structure ty_res; - unify_exp ?type_clash_context env + unify_exp ~context env {texp with exp_type = instance_def ty_res} (instance env ty_expected); end_def (); @@ -3721,8 +3750,7 @@ and type_construct env loc lid sarg ty_expected attrs = | _ -> assert false in let texp = {texp with exp_type = ty_res} in - if not separate then - unify_exp ?type_clash_context env texp (instance env ty_expected); + if not separate then unify_exp ~context env texp (instance env ty_expected); let recarg = match constr.cstr_inlined with | None -> Rejected @@ -3740,7 +3768,7 @@ and type_construct env loc lid sarg ty_expected attrs = in let args = List.map2 - (fun e (t, t0) -> type_argument ~recarg env e t t0) + (fun e (t, t0) -> type_argument ~context ~recarg env e t t0) sargs (List.combine ty_args ty_args0) in @@ -3751,23 +3779,23 @@ and type_construct env loc lid sarg ty_expected attrs = (* Typing of statements (expressions whose values are discarded) *) -and type_statement env sexp = +and type_statement ~context env sexp = let loc = (final_subexpression sexp).pexp_loc in begin_def (); - let exp = type_exp env sexp in + let exp = type_exp ~context env sexp in end_def (); let ty = expand_head env exp.exp_type and tv = newvar () in if is_Tvar ty && ty.level > tv.level then Location.prerr_warning loc Warnings.Nonreturning_statement; let expected_ty = instance_def Predef.type_unit in - let type_clash_context = type_clash_context_in_statement sexp in - unify_exp ?type_clash_context env exp expected_ty; + let context = type_clash_context_in_statement sexp in + unify_exp ~context env exp expected_ty; exp (* Typing of match cases *) -and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res - partial_flag loc caselist : _ * Typedtree.partial = +and type_cases ~(call_context : [`Switch | `Function | `Try]) ?in_function env + ty_arg ty_res partial_flag loc caselist : _ * Typedtree.partial = (* ty_arg is _fully_ generalized *) let patterns = List.map (fun {pc_lhs = p} -> p) caselist in let contains_polyvars = List.exists contains_polymorphic_variant patterns in @@ -3874,19 +3902,20 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res match pc_guard with | None -> None | Some scond -> + (* TODO: Add explicit SwitchIfCondition *) Some - (type_expect - ?type_clash_context: - (if Option.is_some root_type_clash_context then - Some IfCondition - else None) - ext_env + (type_expect ~context:(Some IfCondition) ext_env (wrap_unpacks scond unpacks) Predef.type_bool) in let exp = - type_expect ?type_clash_context:root_type_clash_context ?in_function - ext_env sexp ty_res' + type_expect + ~context: + (match call_context with + | `Switch -> Some SwitchReturn + | `Try -> Some TryReturn + | `Function -> None) + ?in_function ext_env sexp ty_res' in { c_lhs = pat; @@ -3897,7 +3926,7 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res in (if has_gadts then let ty_res' = instance env ty_res in - List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases); + List.iter (fun c -> unify_exp ~context:None env c.c_rhs ty_res') cases); let do_init = has_gadts || needs_exhaust_check in let lev, env = if do_init && not has_gadts then init_env () else (lev, env) in let ty_arg_check = @@ -3922,12 +3951,12 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res if do_init then ( end_def (); (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance env ty_res) (newvar ())); + unify_exp_types ~context:None loc env (instance env ty_res) (newvar ())); (cases, partial) (* Typing of let bindings *) -and type_let ?(check = fun s -> Warnings.Unused_var s) +and type_let ~context ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag spat_sexp_list scope allow = begin_def (); @@ -4060,14 +4089,14 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) let vars, ty' = instance_poly ~keep_names:true true tl ty in let exp = Builtin_attributes.warning_scope pvb_attributes (fun () -> - type_expect exp_env sexp ty') + type_expect ~context exp_env sexp ty') in end_def (); check_univars env true "definition" exp pat.pat_type vars; {exp with exp_type = instance env exp.exp_type} | _ -> Builtin_attributes.warning_scope pvb_attributes (fun () -> - type_expect exp_env sexp pat.pat_type)) + type_expect ~context exp_env sexp pat.pat_type)) spat_sexp_list pat_slot_list in current_slot := None; @@ -4118,22 +4147,22 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) (* Typing of toplevel bindings *) -let type_binding env rec_flag spat_sexp_list scope = +let type_binding ~context env rec_flag spat_sexp_list scope = Typetexp.reset_type_variables (); let pat_exp_list, new_env, _unpacks = type_let ~check:(fun s -> Warnings.Unused_value_declaration s) ~check_strict:(fun s -> Warnings.Unused_value_declaration s) - env rec_flag spat_sexp_list scope false + ~context env rec_flag spat_sexp_list scope false in (pat_exp_list, new_env) (* Typing of toplevel expressions *) -let type_expression env sexp = +let type_expression ~context env sexp = Typetexp.reset_type_variables (); begin_def (); - let exp = type_exp env sexp in + let exp = type_exp ~context env sexp in (if Warnings.is_active (Bs_toplevel_expression_unit None) then try unify env exp.exp_type (instance_def Predef.type_unit) with | Unify _ -> @@ -4220,26 +4249,30 @@ let report_error env loc ppf error = (Ident.name id); spellcheck_idents ppf id valid_idents | Expr_type_clash - ( (_, {desc = Tarrow (_, _, _, _, None)}) - :: (_, {desc = Tarrow (_, _, _, _, Some _)}) - :: _, - _ ) -> + { + trace = + (_, {desc = Tarrow (_, _, _, _, None)}) + :: (_, {desc = Tarrow (_, _, _, _, Some _)}) + :: _; + } -> fprintf ppf "This function is a curried function where an uncurried function is \ expected" | Expr_type_clash - ( (_, {desc = Tarrow (_, _, _, _, Some arity_a)}) - :: (_, {desc = Tarrow (_, _, _, _, Some arity_b)}) - :: _, - _ ) + { + trace = + (_, {desc = Tarrow (_, _, _, _, Some arity_a)}) + :: (_, {desc = Tarrow (_, _, _, _, Some arity_b)}) + :: _; + } when arity_a <> arity_b -> let arity_a = arity_a |> string_of_int in let arity_b = arity_b |> string_of_int in report_arity_mismatch ~arity_a ~arity_b ppf - | Expr_type_clash (trace, type_clash_context) -> + | Expr_type_clash {trace; context} -> (* modified *) fprintf ppf "@["; - print_expr_type_clash ?type_clash_context env loc trace ppf; + print_expr_type_clash ~context env loc trace ppf; fprintf ppf "@]" | Apply_non_function typ -> ( (* modified *) diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli index a167c232c8..8626bd39af 100644 --- a/compiler/ml/typecore.mli +++ b/compiler/ml/typecore.mli @@ -22,12 +22,17 @@ open Format val is_nonexpansive : Typedtree.expression -> bool val type_binding : + context:Error_message_utils.type_clash_context option -> Env.t -> rec_flag -> Parsetree.value_binding list -> Annot.ident option -> Typedtree.value_binding list * Env.t -val type_expression : Env.t -> Parsetree.expression -> Typedtree.expression +val type_expression : + context:Error_message_utils.type_clash_context option -> + Env.t -> + Parsetree.expression -> + Typedtree.expression val check_partial : ?lev:int -> Env.t -> @@ -35,7 +40,11 @@ val check_partial : Location.t -> Typedtree.case list -> Typedtree.partial -val type_exp : Env.t -> Parsetree.expression -> Typedtree.expression +val type_exp : + Env.t -> + Parsetree.expression -> + context:Error_message_utils.type_clash_context option -> + Typedtree.expression val type_approx : Env.t -> Parsetree.expression -> type_expr val option_some : Typedtree.expression -> Typedtree.expression @@ -55,9 +64,10 @@ type error = | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of - (type_expr * type_expr) list - * Error_message_utils.type_clash_context option + | Expr_type_clash of { + trace: (type_expr * type_expr) list; + context: Error_message_utils.type_clash_context option; + } | Apply_non_function of type_expr | Apply_wrong_label of Noloc.arg_label * type_expr | Label_multiply_defined of { diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index 0419c76e99..3f43b27895 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -1356,7 +1356,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_attributes = smod.pmod_attributes; } | Pmod_unpack sexp -> - let exp = Typecore.type_exp env sexp in + let exp = Typecore.type_exp ~context:None env sexp in let mty = match Ctype.expand_head env exp.exp_type with | {desc = Tpackage (p, nl, tl)} -> @@ -1391,7 +1391,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_eval (sexpr, attrs) -> let expr = Builtin_attributes.warning_scope attrs (fun () -> - Typecore.type_expression env sexpr) + Typecore.type_expression ~context:None env sexpr) in (Tstr_eval (expr, attrs), [], env) | Pstr_value (rec_flag, sdefs) -> @@ -1408,7 +1408,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = in Some (Annot.Idef {scope with Location.loc_start = start}) in - let defs, newenv = Typecore.type_binding env rec_flag sdefs scope in + let defs, newenv = + Typecore.type_binding ~context:None env rec_flag sdefs scope + in let () = if rec_flag = Recursive then Rec_check.check_recursive_bindings defs in diff --git a/tests/build_tests/super_errors/expected/function_return_mismatch.res.expected b/tests/build_tests/super_errors/expected/function_return_mismatch.res.expected index dc0dcc30a0..9e66c7351b 100644 --- a/tests/build_tests/super_errors/expected/function_return_mismatch.res.expected +++ b/tests/build_tests/super_errors/expected/function_return_mismatch.res.expected @@ -1,12 +1,12 @@ We've found a bug for you! - /.../fixtures/function_return_mismatch.res:9:3-5 + /.../fixtures/function_return_mismatch.res:11:3-5 - 7 │ - 8 │ let x = fnExpectingCleanup(() => { - 9 │ 123 - 10 │ }) - 11 │ + 9 │ Console.log("Hello, world!") + 10 │ let _f = 2 + 11 │ 123 + 12 │ }) + 13 │ This has type: int But it's expected to have type: cleanup (defined as unit => unit) \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/switch_different_types.res.expected b/tests/build_tests/super_errors/expected/switch_different_types.res.expected index 14e96e8964..af51c78462 100644 --- a/tests/build_tests/super_errors/expected/switch_different_types.res.expected +++ b/tests/build_tests/super_errors/expected/switch_different_types.res.expected @@ -11,4 +11,5 @@ This has type: string But this switch is expected to return: unit - All branches in a switch must return the same type. To fix this, change your branch to return the expected type. \ No newline at end of file + All branches in a switch must return the same type. + To fix this, change your branch to return the expected type. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/try_catch_same_type.res.expected b/tests/build_tests/super_errors/expected/try_catch_same_type.res.expected new file mode 100644 index 0000000000..55bacd0f95 --- /dev/null +++ b/tests/build_tests/super_errors/expected/try_catch_same_type.res.expected @@ -0,0 +1,16 @@ + + We've found a bug for you! + /.../fixtures/try_catch_same_type.res:2:8-14 + + 1 │ let x = try {1} catch { + 2 │ | _ => "hello" + 3 │ } + 4 │ + + This has type: string + But this try/catch is expected to return: int + + The try body and the catch block must return the same type. + To fix this, change your try/catch blocks to return the expected type. + + You can convert string to int with Int.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/function_return_mismatch.res b/tests/build_tests/super_errors/fixtures/function_return_mismatch.res index 7907de2b39..f289842cc9 100644 --- a/tests/build_tests/super_errors/fixtures/function_return_mismatch.res +++ b/tests/build_tests/super_errors/fixtures/function_return_mismatch.res @@ -6,5 +6,7 @@ let fnExpectingCleanup = (cb: unit => cleanup) => { } let x = fnExpectingCleanup(() => { + Console.log("Hello, world!") + let _f = 2 123 }) diff --git a/tests/build_tests/super_errors/fixtures/try_catch_same_type.res b/tests/build_tests/super_errors/fixtures/try_catch_same_type.res new file mode 100644 index 0000000000..f879b123c7 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/try_catch_same_type.res @@ -0,0 +1,3 @@ +let x = try {1} catch { +| _ => "hello" +} From 96ed8a32bde95e3f120fb8ae75058eb08c4b8434 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 May 2025 18:55:58 +0200 Subject: [PATCH 02/17] explicit error for while condition --- compiler/ml/error_message_utils.ml | 3 +++ compiler/ml/typecore.ml | 5 +---- .../super_errors/expected/while_condition.res.expected | 10 ++++++++++ .../super_errors/fixtures/while_condition.res | 3 +++ 4 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/while_condition.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/while_condition.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index ad858261dd..788ee8dfdf 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -80,6 +80,7 @@ type type_clash_context = | TryReturn | StringConcat | ComparisonOperator + | WhileCondition | MathOperator of { for_float: bool; operator: string; @@ -110,6 +111,8 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But it's being compared to something of type:" | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:" | Some TryReturn -> fprintf ppf "But this try/catch is expected to return:" + | Some WhileCondition -> + fprintf ppf "But a @{while@} loop condition must always be of type:" | Some IfCondition -> fprintf ppf "But @{if@} conditions must always be of type:" | Some IfReturn -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 43c0e53f60..2b3046a8a3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1887,7 +1887,6 @@ let rec approx_type env sty = | Ptyp_poly (_, sty) -> approx_type env sty | _ -> newvar () -(* TODO: Needs type clash context? *) let rec type_approx env sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) -> type_approx env e @@ -2849,8 +2848,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected } | Pexp_while (scond, sbody) -> let cond = - (* TODO: Add explicit WhileCondition *) - type_expect ~context:(Some IfCondition) env scond Predef.type_bool + type_expect ~context:(Some WhileCondition) env scond Predef.type_bool in let body = type_statement ~context:None env sbody in rue @@ -3902,7 +3900,6 @@ and type_cases ~(call_context : [`Switch | `Function | `Try]) ?in_function env match pc_guard with | None -> None | Some scond -> - (* TODO: Add explicit SwitchIfCondition *) Some (type_expect ~context:(Some IfCondition) ext_env (wrap_unpacks scond unpacks) diff --git a/tests/build_tests/super_errors/expected/while_condition.res.expected b/tests/build_tests/super_errors/expected/while_condition.res.expected new file mode 100644 index 0000000000..15d8427d8a --- /dev/null +++ b/tests/build_tests/super_errors/expected/while_condition.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/while_condition.res:1:7-13 + + 1 │ while "horse" { + 2 │ Console.log("What") + 3 │ } + + This has type: string + But a while loop condition must always be of type: bool \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/while_condition.res b/tests/build_tests/super_errors/fixtures/while_condition.res new file mode 100644 index 0000000000..d370bb30df --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/while_condition.res @@ -0,0 +1,3 @@ +while "horse" { + Console.log("What") +} From b80fea513222a4223c2e7ab99b89b47a2bc49429 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 May 2025 19:00:02 +0200 Subject: [PATCH 03/17] explicit for loop condition --- compiler/ml/error_message_utils.ml | 3 +++ compiler/ml/typecore.ml | 9 ++++++--- .../expected/for_loop_condition.res.expected | 12 ++++++++++++ .../super_errors/fixtures/for_loop_condition.res | 3 +++ 4 files changed, 24 insertions(+), 3 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/for_loop_condition.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/for_loop_condition.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 788ee8dfdf..3880f27a75 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -88,6 +88,7 @@ type type_clash_context = } | FunctionArgument | Statement of type_clash_statement + | ForLoopCondition let fprintf = Format.fprintf @@ -113,6 +114,8 @@ let error_expected_type_text ppf type_clash_context = | Some TryReturn -> fprintf ppf "But this try/catch is expected to return:" | Some WhileCondition -> fprintf ppf "But a @{while@} loop condition must always be of type:" + | Some ForLoopCondition -> + fprintf ppf "But a @{for@} loop bounds must always be of type:" | Some IfCondition -> fprintf ppf "But @{if@} conditions must always be of type:" | Some IfReturn -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 2b3046a8a3..260113d701 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2861,9 +2861,12 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_for (param, slow, shigh, dir, sbody) -> - (* TODO: Add explicit ForCondition *) - let low = type_expect ~context:None env slow Predef.type_int in - let high = type_expect ~context:None env shigh Predef.type_int in + let low = + type_expect ~context:(Some ForLoopCondition) env slow Predef.type_int + in + let high = + type_expect ~context:(Some ForLoopCondition) env shigh Predef.type_int + in let id, new_env = match param.ppat_desc with | Ppat_any -> (Ident.create "_for", env) diff --git a/tests/build_tests/super_errors/expected/for_loop_condition.res.expected b/tests/build_tests/super_errors/expected/for_loop_condition.res.expected new file mode 100644 index 0000000000..f7f1b7d110 --- /dev/null +++ b/tests/build_tests/super_errors/expected/for_loop_condition.res.expected @@ -0,0 +1,12 @@ + + We've found a bug for you! + /.../fixtures/for_loop_condition.res:1:16-19 + + 1 │ for (x in 0 to "10") { + 2 │ Console.log(x) + 3 │ } + + This has type: string + But a for loop bounds must always be of type: int + + You can convert string to int with Int.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/for_loop_condition.res b/tests/build_tests/super_errors/fixtures/for_loop_condition.res new file mode 100644 index 0000000000..779f8c3801 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/for_loop_condition.res @@ -0,0 +1,3 @@ +for x in 0 to "10" { + Console.log(x) +} From 6e5d149e06ffa1b3f480ba632e1e9e26e814eebb Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sat, 24 May 2025 19:02:10 +0200 Subject: [PATCH 04/17] assert condition --- compiler/ml/error_message_utils.ml | 2 ++ compiler/ml/typecore.ml | 5 +++-- .../super_errors/expected/assert_condition.res.expected | 9 +++++++++ .../expected/for_loop_condition.res.expected | 4 ++-- .../super_errors/fixtures/assert_condition.res | 1 + 5 files changed, 17 insertions(+), 4 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/assert_condition.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/assert_condition.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 3880f27a75..800abd240d 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -75,6 +75,7 @@ type type_clash_context = | ArrayValue | MaybeUnwrapOption | IfCondition + | AssertCondition | IfReturn | SwitchReturn | TryReturn @@ -118,6 +119,7 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But a @{for@} loop bounds must always be of type:" | Some IfCondition -> fprintf ppf "But @{if@} conditions must always be of type:" + | Some AssertCondition -> fprintf ppf "But assertions must always be of type:" | Some IfReturn -> fprintf ppf "But this @{if@} statement is expected to return:" | Some ArrayValue -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 260113d701..82554bc423 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3071,8 +3071,9 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_assert e -> - (* TODO: Add explicit AssertCondition *) - let cond = type_expect ~context:(Some IfCondition) env e Predef.type_bool in + let cond = + type_expect ~context:(Some AssertCondition) env e Predef.type_bool + in let exp_type = match cond.exp_desc with | Texp_construct (_, {cstr_name = "false"}, _) -> instance env ty_expected diff --git a/tests/build_tests/super_errors/expected/assert_condition.res.expected b/tests/build_tests/super_errors/expected/assert_condition.res.expected new file mode 100644 index 0000000000..5dcb3be611 --- /dev/null +++ b/tests/build_tests/super_errors/expected/assert_condition.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/assert_condition.res:1:8-14 + + 1 │ assert("horse") + 2 │ + + This has type: string + But assertions must always be of type: bool \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/for_loop_condition.res.expected b/tests/build_tests/super_errors/expected/for_loop_condition.res.expected index f7f1b7d110..d00bebec45 100644 --- a/tests/build_tests/super_errors/expected/for_loop_condition.res.expected +++ b/tests/build_tests/super_errors/expected/for_loop_condition.res.expected @@ -1,8 +1,8 @@ We've found a bug for you! - /.../fixtures/for_loop_condition.res:1:16-19 + /.../fixtures/for_loop_condition.res:1:15-18 - 1 │ for (x in 0 to "10") { + 1 │ for x in 0 to "10" { 2 │ Console.log(x) 3 │ } diff --git a/tests/build_tests/super_errors/fixtures/assert_condition.res b/tests/build_tests/super_errors/fixtures/assert_condition.res new file mode 100644 index 0000000000..5e753af146 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/assert_condition.res @@ -0,0 +1 @@ +assert("horse") From 9cd6bfd79de13189442d89ed9cb25505ec4ab736 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 May 2025 13:59:17 +0200 Subject: [PATCH 05/17] refactor --- compiler/ml/error_message_utils.ml | 18 +++++++++++++ compiler/ml/typecore.ml | 42 +++++++++++++----------------- 2 files changed, 36 insertions(+), 24 deletions(-) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 800abd240d..6a895c5b26 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -91,6 +91,24 @@ type type_clash_context = | Statement of type_clash_statement | ForLoopCondition +let context_to_string = function + | Some WhileCondition -> "WhileCondition" + | Some ForLoopCondition -> "ForLoopCondition" + | Some AssertCondition -> "AssertCondition" + | Some IfCondition -> "IfCondition" + | Some (Statement _) -> "Statement" + | Some (MathOperator _) -> "MathOperator" + | Some ArrayValue -> "ArrayValue" + | Some SetRecordField -> "SetRecordField" + | Some MaybeUnwrapOption -> "MaybeUnwrapOption" + | Some SwitchReturn -> "SwitchReturn" + | Some TryReturn -> "TryReturn" + | Some StringConcat -> "StringConcat" + | Some FunctionArgument -> "FunctionArgument" + | Some ComparisonOperator -> "ComparisonOperator" + | Some IfReturn -> "IfReturn" + | None -> "None" + let fprintf = Format.fprintf let error_type_text ppf type_clash_context = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 82554bc423..711f540333 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2384,14 +2384,14 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected [Vb.mk spat smatch] sbody in - type_function ~context:None ?in_function ~arity ~async loc - sexp.pexp_attributes env ty_expected l + type_function ?in_function ~arity ~async loc sexp.pexp_attributes env + ty_expected l [Exp.case pat body] | Pexp_fun {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} -> let l = Asttypes.to_noloc l in - type_function ~context:None ?in_function ~arity ~async loc - sexp.pexp_attributes env ty_expected l + type_function ?in_function ~arity ~async loc sexp.pexp_attributes env + ty_expected l [Ast_helper.Exp.case spat sbody] | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> assert (sargs <> []); @@ -2405,7 +2405,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected let total_app = not partial in let context = type_clash_context_from_function sexp sfunct in let args, ty_res, fully_applied = - match translate_unified_ops ~context:None env funct sargs with + match translate_unified_ops env funct sargs with | Some (targs, result_type) -> (targs, result_type, true) | None -> type_application ~context total_app env funct sargs in @@ -2503,8 +2503,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_construct (lid, sarg) -> - type_construct ~context:None env loc lid sarg ty_expected - sexp.pexp_attributes + type_construct env loc lid sarg ty_expected sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( (* Keep sharing *) let ty_expected0 = instance env ty_expected in @@ -2519,7 +2518,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected row_field_repr (List.assoc l row0.row_fields) ) with | Rpresent (Some ty), Rpresent (Some ty0) -> - let arg = type_argument ~context env sarg ty ty0 in + let arg = type_argument ~context:None env sarg ty ty0 in re { exp_desc = Texp_variant (l, Some arg); @@ -2749,7 +2748,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_field (srecord, lid) -> - let record, label, _ = type_label_access ~context:None env srecord lid in + let record, label, _ = type_label_access env srecord lid in let _, ty_arg, ty_res = instance_label false label in unify_exp ~context:None env record ty_res; rue @@ -2762,9 +2761,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_setfield (srecord, lid, snewval) -> - let record, label, opath = - type_label_access ~context:None env srecord lid - in + let record, label, opath = type_label_access env srecord lid in let ty_record = if opath = None then newvar () else record.exp_type in let label_loc, label, newval, _ = type_label_exp ~context:(Some SetRecordField) false env loc ty_record @@ -2836,7 +2833,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected }) | Pexp_sequence (sexp1, sexp2) -> let exp1 = type_statement ~context:None env sexp1 in - let exp2 = type_expect ~context env sexp2 ty_expected in + let exp2 = type_expect ~context:None env sexp2 ty_expected in re { exp_desc = Texp_sequence (exp1, exp2); @@ -2927,7 +2924,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected if separate then begin_def (); (* TODO: What should this be?*) let type_clash_context = None in - let arg = type_exp ~context env sarg in + let arg = type_exp ~context:None env sarg in let gen = if separate then ( end_def (); @@ -3202,8 +3199,8 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected | Pexp_jsx_element _ -> failwith "Pexp_jsx_element is expected to be transformed at this point" -and type_function ~context ?in_function ~arity ~async loc attrs env ty_expected_ - l caselist = +and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l + caselist = let state = Warnings.backup () in (* Disable Unerasable_optional_argument for uncurried functions *) let unerasable_optional_argument = @@ -3215,7 +3212,7 @@ and type_function ~context ?in_function ~arity ~async loc attrs env ty_expected_ | None -> ty_expected_ | Some arity -> let fun_t = newty (Tarrow (l, newvar (), newvar (), Cok, Some arity)) in - unify_exp_types ~context loc env fun_t ty_expected_; + unify_exp_types ~context:None loc env fun_t ty_expected_; fun_t in let loc_fun, ty_fun = @@ -3270,8 +3267,8 @@ and type_function ~context ?in_function ~arity ~async loc attrs env ty_expected_ exp_env = env; } -and type_label_access ~context env srecord lid = - let record = type_exp ~context ~recarg:Allowed env srecord in +and type_label_access env srecord lid = + let record = type_exp ~context:None ~recarg:Allowed env srecord in let ty_exp = record.exp_type in let opath = try @@ -3356,9 +3353,8 @@ and type_argument ~context ?recarg env sarg ty_expected' ty_expected = (** This is ad-hoc translation for unifying specific primitive operations See [Unified_ops] module for detailed explanation. *) -and translate_unified_ops ~context (env : Env.t) (funct : Typedtree.expression) +and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) (sargs : sargs) : (targs * Types.type_expr) option = - ignore context; match funct.exp_desc with | Texp_ident (path, _, _) -> ( let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in @@ -3687,9 +3683,7 @@ and type_application ~context total_app env funct (sargs : sargs) : in (targs, ret_t, fully_applied) -and type_construct ~context env loc lid sarg ty_expected attrs = - (* TODO: Fix this *) - ignore context; +and type_construct env loc lid sarg ty_expected attrs = let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in From 01288d3b6ebb745000f3932a7d34d5f747437353 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 26 May 2025 14:08:01 +0200 Subject: [PATCH 06/17] fix --- compiler/ml/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 711f540333..7188256ab4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2653,7 +2653,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected } | Pexp_record (lid_sexp_list, Some sexp) -> assert (lid_sexp_list <> []); - let exp = type_expect ~context:None ~recarg env sexp (newvar ()) in + let exp = type_exp ~context:None ~recarg env sexp in let ty_record, opath = let get_path ty = try From 374d5630ecae63a79aa15952de1009fac84faffc Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 27 May 2025 09:39:53 +0200 Subject: [PATCH 07/17] try tracking record field type checking --- compiler/ml/error_message_utils.ml | 13 +++++++---- compiler/ml/typecore.ml | 23 +++++++++++++------ ...line_types_record_type_params.res.expected | 2 +- 3 files changed, 26 insertions(+), 12 deletions(-) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 6a895c5b26..63aaaf18bc 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -71,7 +71,8 @@ let type_expr ppf typ = type type_clash_statement = FunctionCall type type_clash_context = - | SetRecordField + | SetRecordField of string (* field name *) + | RecordField of string (* field name *) | ArrayValue | MaybeUnwrapOption | IfCondition @@ -99,7 +100,8 @@ let context_to_string = function | Some (Statement _) -> "Statement" | Some (MathOperator _) -> "MathOperator" | Some ArrayValue -> "ArrayValue" - | Some SetRecordField -> "SetRecordField" + | Some (SetRecordField _) -> "SetRecordField" + | Some (RecordField _) -> "RecordField" | Some MaybeUnwrapOption -> "MaybeUnwrapOption" | Some SwitchReturn -> "SwitchReturn" | Some TryReturn -> "TryReturn" @@ -117,7 +119,7 @@ let error_type_text ppf type_clash_context = | Some (Statement FunctionCall) -> "This function call returns:" | Some (MathOperator {is_constant = Some _}) -> "This value has type:" | Some ArrayValue -> "This array item has type:" - | Some SetRecordField -> + | Some (SetRecordField _) -> "You're assigning something to this field that has type:" | _ -> "This has type:" in @@ -142,7 +144,10 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But this @{if@} statement is expected to return:" | Some ArrayValue -> fprintf ppf "But this array is expected to have items of type:" - | Some SetRecordField -> fprintf ppf "But this record field is of type:" + | Some (SetRecordField _) -> fprintf ppf "But this record field is of type:" + | Some (RecordField field_name) -> + fprintf ppf "But this record field @{%s@} is expected to have type:" + field_name | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:" | Some (MathOperator {operator}) -> fprintf ppf diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 7188256ab4..6536a9e5af 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2575,7 +2575,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected (type_record_elem_list loc true env (fun e k -> k - (type_label_exp ~context:None true env loc ty_record + (type_label_exp ~call_context:`Regular true env loc ty_record (process_optional_label e))) opath lid_sexp_list) (fun x -> x) @@ -2685,7 +2685,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected (type_record_elem_list loc closed env (fun e k -> k - (type_label_exp ~context:None true env loc ty_record + (type_label_exp ~call_context:`Regular true env loc ty_record (process_optional_label e))) opath lid_sexp_list) (fun x -> x) @@ -2764,7 +2764,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected let record, label, opath = type_label_access env srecord lid in let ty_record = if opath = None then newvar () else record.exp_type in let label_loc, label, newval, _ = - type_label_exp ~context:(Some SetRecordField) false env loc ty_record + type_label_exp ~call_context:`SetRecordField false env loc ty_record (lid, label, snewval, false) in unify_exp ~context:None env record ty_record; @@ -3296,7 +3296,8 @@ and type_label_access env srecord lid = (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) -and type_label_exp ~context create env loc ty_expected (lid, label, sarg, opt) = +and type_label_exp ~(call_context : [`SetRecordField | `Regular]) create env loc + ty_expected (lid, label, sarg, opt) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = Env.has_local_constraints env in @@ -3323,7 +3324,15 @@ and type_label_exp ~context create env loc ty_expected (lid, label, sarg, opt) = else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = type_argument ~context env sarg ty_arg (instance env ty_arg) in + let field_name = Longident.last lid.txt in + let field_context = + match call_context with + | `SetRecordField -> Some (Error_message_utils.SetRecordField field_name) + | `Regular -> Some (Error_message_utils.RecordField field_name) + in + let arg = + type_argument ~context:field_context env sarg ty_arg (instance env ty_arg) + in end_def (); try check_univars env (vars <> []) "field value" arg label.lbl_arg vars; @@ -3333,10 +3342,10 @@ and type_label_exp ~context create env loc ty_expected (lid, label, sarg, opt) = (* Try to retype without propagating ty_arg, cf PR#4862 *) may Btype.backtrack snap; begin_def (); - let arg = type_exp ~context env sarg in + let arg = type_exp ~context:field_context env sarg in end_def (); generalize_expansive env arg.exp_type; - unify_exp ~context env arg ty_arg; + unify_exp ~context:field_context env arg ty_arg; check_univars env false "field value" arg label.lbl_arg vars; arg with diff --git a/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected index 8a69447541..7e304a17de 100644 --- a/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected +++ b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected @@ -9,6 +9,6 @@ 15 ┆ otherExtra: Some({test: true, anotherInlined: {record: true}}), This has type: int - But it's expected to have type: string + But this record field age is expected to have type: string You can convert int to string with Int.toString. \ No newline at end of file From ab01839e3585bba34f7a5bbe84dba915ba677ad3 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 30 May 2025 20:21:10 +0200 Subject: [PATCH 08/17] iron out a few more error messages --- compiler/ml/error_message_utils.ml | 109 ++++++++++++++---- compiler/ml/typecore.ml | 44 +++++-- ...jsx_custom_component_children.res.expected | 14 +++ ...jsx_custom_component_optional.res.expected | 13 +++ .../jsx_type_mismatch_float.res.expected | 3 +- .../jsx_type_mismatch_int.res.expected | 3 +- .../jsx_type_mismatch_string.res.expected | 3 +- ...onal_record_field_pass_option.res.expected | 17 +++ .../jsx_custom_component_children.res | 24 ++++ .../jsx_custom_component_optional.res | 31 +++++ .../optional_record_field_pass_option.res | 6 + 11 files changed, 228 insertions(+), 39 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected create mode 100644 tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected create mode 100644 tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/jsx_custom_component_children.res create mode 100644 tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res create mode 100644 tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 63aaaf18bc..d5b423e0db 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -69,10 +69,21 @@ let type_expr ppf typ = Printtyp.reset_and_mark_loops typ; Printtyp.type_expr ppf typ +type jsx_prop_error_info = { + fields: Types.label_declaration list; + props_record_path: Path.t; + jsx_type: [`Fragment | `CustomComponent | `LowercaseComponent]; +} + type type_clash_statement = FunctionCall type type_clash_context = | SetRecordField of string (* field name *) - | RecordField of string (* field name *) + | RecordField of { + jsx: jsx_prop_error_info option; + record_type: Types.type_expr; + field_name: string; + optional: bool; + } | ArrayValue | MaybeUnwrapOption | IfCondition @@ -88,7 +99,7 @@ type type_clash_context = operator: string; is_constant: string option; } - | FunctionArgument + | FunctionArgument of {optional: bool} | Statement of type_clash_statement | ForLoopCondition @@ -106,7 +117,7 @@ let context_to_string = function | Some SwitchReturn -> "SwitchReturn" | Some TryReturn -> "TryReturn" | Some StringConcat -> "StringConcat" - | Some FunctionArgument -> "FunctionArgument" + | Some (FunctionArgument _) -> "FunctionArgument" | Some ComparisonOperator -> "ComparisonOperator" | Some IfReturn -> "IfReturn" | None -> "None" @@ -127,8 +138,11 @@ let error_type_text ppf type_clash_context = let error_expected_type_text ppf type_clash_context = match type_clash_context with - | Some FunctionArgument -> - fprintf ppf "But this function argument is expecting:" + | Some (FunctionArgument {optional}) -> + fprintf ppf "But this%s function argument is expecting:" + (match optional with + | false -> "" + | true -> " optional") | Some ComparisonOperator -> fprintf ppf "But it's being compared to something of type:" | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:" @@ -145,7 +159,19 @@ let error_expected_type_text ppf type_clash_context = | Some ArrayValue -> fprintf ppf "But this array is expected to have items of type:" | Some (SetRecordField _) -> fprintf ppf "But this record field is of type:" - | Some (RecordField field_name) -> + | Some + (RecordField {field_name = "children"; jsx = Some {jsx_type = `Fragment}}) + -> + fprintf ppf "But children of JSX fragments is expected to have type:" + | Some + (RecordField + {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) -> + fprintf ppf + "But children passed to this component is expected to have type:" + | Some (RecordField {field_name; jsx = Some _}) -> + fprintf ppf "But this component prop @{%s@} is expected to have type:" + field_name + | Some (RecordField {field_name}) -> fprintf ppf "But this record field @{%s@} is expected to have type:" field_name | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:" @@ -395,6 +421,40 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf single JSX element.@," (with_configured_jsx_module "array") | _ -> ()) + | ( Some (RecordField {optional = true; field_name}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + @{%s@} is an optional record field, and you're passing an \ + optional value to it.@,\ + Optional fields expect you to pass the concrete value, not an option, \ + when passed directly.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option and pass a concrete value directly@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{{%s: ?%s@}}" + field_name field_name + (Parser.extract_text_at_loc loc) + | ( Some (FunctionArgument {optional = true}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + You're passing an optional value into an optional function argument.@,\ + Optional function arguments expect you to pass the concrete value, not \ + an option, when passed directly.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option and pass a concrete value directly@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{?%s@}" + (Parser.extract_text_at_loc loc) | _, Some (t1, t2) -> let is_subtype = try @@ -450,7 +510,7 @@ let type_clash_context_from_function sexp sfunct = Some (MathOperator {for_float = true; operator; is_constant}) | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} -> Some (MathOperator {for_float = false; operator; is_constant}) - | _ -> Some FunctionArgument + | _ -> Some (FunctionArgument {optional = false}) let type_clash_context_for_function_argument type_clash_context sarg0 = match type_clash_context with @@ -508,11 +568,6 @@ let print_contextual_unification_error ppf t1 t2 = the highlighted pattern in @{Some()@} to make it work.@]" | _ -> () -type jsx_prop_error_info = { - fields: Types.label_declaration list; - props_record_path: Path.t; -} - let attributes_include_jsx_component_props (attrs : Parsetree.attributes) = attrs |> List.exists (fun ({Location.txt}, _) -> txt = "res.jsxComponentProps") @@ -524,18 +579,24 @@ let path_to_jsx_component_name p = let get_jsx_component_props ~(extract_concrete_typedecl : extract_concrete_typedecl) env ty p = - match Path.last p with - | "props" -> ( - try - match extract_concrete_typedecl env ty with - | ( _p0, - _p, - {Types.type_kind = Type_record (fields, _repr); type_attributes} ) - when attributes_include_jsx_component_props type_attributes -> - Some {props_record_path = p; fields} - | _ -> None - with _ -> None) - | _ -> None + match p with + | Path.Pdot (Path.Pident {Ident.name = jsx_module_name}, "fragmentProps", _) + when Some jsx_module_name = !configured_jsx_module -> + Some {props_record_path = p; fields = []; jsx_type = `Fragment} + | _ -> ( + (* TODO: handle lowercase components using JSXDOM.domProps *) + match Path.last p with + | "props" -> ( + try + match extract_concrete_typedecl env ty with + | ( _p0, + _p, + {Types.type_kind = Type_record (fields, _repr); type_attributes} ) + when attributes_include_jsx_component_props type_attributes -> + Some {props_record_path = p; fields; jsx_type = `CustomComponent} + | _ -> None + with _ -> None) + | _ -> None) let print_component_name ppf (p : Path.t) = match path_to_jsx_component_name p with diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 6536a9e5af..de6c2f6e24 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2503,7 +2503,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_env = env; } | Pexp_construct (lid, sarg) -> - type_construct env loc lid sarg ty_expected sexp.pexp_attributes + type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes | Pexp_variant (l, sarg) -> ( (* Keep sharing *) let ty_expected0 = instance env ty_expected in @@ -2570,13 +2570,15 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected get_jsx_component_props ~extract_concrete_typedecl env ty_record p | None -> None in + (* React.fragmentProps, JSXDOM.domProps *) + let jsx_component_error_info = get_jsx_component_error_info () in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" ty_record (type_record_elem_list loc true env (fun e k -> k - (type_label_exp ~call_context:`Regular true env loc ty_record - (process_optional_label e))) + (type_label_exp ~call_context:(`Regular jsx_component_error_info) + true env loc ty_record (process_optional_label e))) opath lid_sexp_list) (fun x -> x) in @@ -2601,7 +2603,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected Labels_missing { labels = labels_missing; - jsx_component_info = get_jsx_component_error_info (); + jsx_component_info = jsx_component_error_info; } )); ([||], representation) | [], _ -> @@ -2634,7 +2636,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected Labels_missing { labels = List.rev !labels_missing; - jsx_component_info = get_jsx_component_error_info (); + jsx_component_info = jsx_component_error_info; } )); let fields = Array.map2 @@ -2680,13 +2682,14 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected ty_record in let closed = false in + let jsx_component_error_info = get_jsx_component_error_info () in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" ty_record (type_record_elem_list loc closed env (fun e k -> k - (type_label_exp ~call_context:`Regular true env loc ty_record - (process_optional_label e))) + (type_label_exp ~call_context:(`Regular jsx_component_error_info) + true env loc ty_record (process_optional_label e))) opath lid_sexp_list) (fun x -> x) in @@ -3296,8 +3299,8 @@ and type_label_access env srecord lid = (* Typing format strings for printing or reading. These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) -and type_label_exp ~(call_context : [`SetRecordField | `Regular]) create env loc - ty_expected (lid, label, sarg, opt) = +and type_label_exp ~call_context create env loc ty_expected + (lid, label, sarg, opt) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = Env.has_local_constraints env in @@ -3328,7 +3331,10 @@ and type_label_exp ~(call_context : [`SetRecordField | `Regular]) create env loc let field_context = match call_context with | `SetRecordField -> Some (Error_message_utils.SetRecordField field_name) - | `Regular -> Some (Error_message_utils.RecordField field_name) + | `Regular jsx -> + Some + (Error_message_utils.RecordField + {jsx; record_type = ty_expected; field_name; optional = false}) in let arg = type_argument ~context:field_context env sarg ty_arg (instance env ty_arg) @@ -3692,7 +3698,7 @@ and type_application ~context total_app env funct (sargs : sargs) : in (targs, ret_t, fully_applied) -and type_construct env loc lid sarg ty_expected attrs = +and type_construct ~context env loc lid sarg ty_expected attrs = let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -3739,7 +3745,21 @@ and type_construct env loc lid sarg ty_expected attrs = exp_env = env; } in - let context = type_clash_context_maybe_option ty_expected ty_res in + (* Forward context if this is a Some constructor injected (meaning it's + an optional field or an optional argument) *) + let context = + match lid.txt with + | Longident.Ldot (Lident "*predef*", "Some") -> ( + match context with + | Some (RecordField {record_type; jsx; field_name}) -> + Some + (Error_message_utils.RecordField + {record_type; jsx; field_name; optional = true}) + | Some (FunctionArgument _) -> + Some (Error_message_utils.FunctionArgument {optional = true}) + | _ -> None) + | _ -> None + in if separate then ( end_def (); generalize_structure ty_res; diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected new file mode 100644 index 0000000000..5f71bf3277 --- /dev/null +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/jsx_custom_component_children.res:24:28-29 + + 22 │ } + 23 │ + 24 │ let x = {1.} + 25 │ + + This has type: float + But children passed to this component is expected to have type: + React.element (defined as Jsx.element) + + In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected new file mode 100644 index 0000000000..317bac459d --- /dev/null +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/jsx_custom_component_optional.res:31:34-40 + + 29 │ } + 30 │ + 31 │ let x = + 32 │ + + This has type: string + But this component prop someOpt is expected to have type: float + + You can convert string to float with Float.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected index af4279bd52..75096b66fd 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected @@ -8,6 +8,7 @@ 18 │ This has type: float - But it's expected to have type: React.element (defined as Jsx.element) + But children of JSX fragments is expected to have type: + React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected index 5a43157d03..0c7bd8f665 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected @@ -8,6 +8,7 @@ 18 │ This has type: int - But it's expected to have type: React.element (defined as Jsx.element) + But children of JSX fragments is expected to have type: + React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert int to a JSX element with React.int. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected index 10d1d64dc7..bdf80bd0bb 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected @@ -8,6 +8,7 @@ 18 │ This has type: string - But it's expected to have type: React.element (defined as Jsx.element) + But children of JSX fragments is expected to have type: + React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert string to a JSX element with React.string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected new file mode 100644 index 0000000000..59d59caa59 --- /dev/null +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -0,0 +1,17 @@ + + We've found a bug for you! + /.../fixtures/optional_record_field_pass_option.res:6:16 + + 4 │ let t = Some(true) + 5 │ + 6 │ let x = {test: t} + + This has type: option + But this record field test is expected to have type: bool + + test is an optional record field, and you're passing an optional value to it. + Optional fields expect you to pass the concrete value, not an option, when passed directly. + + Possible solutions: + - Unwrap the option and pass a concrete value directly + - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: {test: ?t} \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/jsx_custom_component_children.res b/tests/build_tests/super_errors/fixtures/jsx_custom_component_children.res new file mode 100644 index 0000000000..b4059e242b --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/jsx_custom_component_children.res @@ -0,0 +1,24 @@ +@@config({ + flags: ["-bs-jsx", "4"], +}) + +module React = { + type element = Jsx.element + type componentLike<'props, 'return> = 'props => 'return + type component<'props> = Jsx.component<'props> + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + type fragmentProps = {children?: element} + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" +} + +module CustomComponent = { + @react.component + let make = (~children) => { + <> {children} + } +} + +let x = {1.} diff --git a/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res b/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res new file mode 100644 index 0000000000..58759ac7e8 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res @@ -0,0 +1,31 @@ +@@config({ + flags: ["-bs-jsx", "4"], +}) + +module React = { + type element = Jsx.element + type componentLike<'props, 'return> = 'props => 'return + type component<'props> = Jsx.component<'props> + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + type fragmentProps = {children?: element} + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" + + external float: float => element = "%identity" +} + +module CustomComponent = { + @react.component + let make = (~someOpt=?) => { + React.float( + switch someOpt { + | Some(5.) => 1. + | _ => 2. + }, + ) + } +} + +let x = diff --git a/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res b/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res new file mode 100644 index 0000000000..0f12983909 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res @@ -0,0 +1,6 @@ +type record = { + test?: bool +} +let t = Some(true) + +let x = {test: t} \ No newline at end of file From 9411f977b6c4c62d38c469da78336af11e558b39 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 30 May 2025 20:33:24 +0200 Subject: [PATCH 09/17] track optional function arguments --- compiler/ml/error_message_utils.ml | 1 + compiler/ml/typecore.ml | 4 +++- ...tional_fn_argument_pass_option.res.expected | 18 ++++++++++++++++++ .../optional_fn_argument_pass_option.res | 5 +++++ 4 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/optional_fn_argument_pass_option.res diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index d5b423e0db..af225d7a5a 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -527,6 +527,7 @@ let type_clash_context_for_function_argument type_clash_context sarg0 = Some txt | _ -> None); }) + | None -> Some (FunctionArgument {optional = false}) | type_clash_context -> type_clash_context let type_clash_context_maybe_option ty_expected ty_res = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index de6c2f6e24..5691858afb 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3657,7 +3657,9 @@ and type_application ~context total_app env funct (sargs : sargs) : env sarg0 ty ty0 else fun () -> option_some - (type_argument ~context env sarg0 + (type_argument + ~context:(Some (FunctionArgument {optional = true})) + env sarg0 (extract_option_type env ty) (extract_option_type env ty0))) ) in diff --git a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected new file mode 100644 index 0000000000..68e129ba29 --- /dev/null +++ b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected @@ -0,0 +1,18 @@ + + We've found a bug for you! + /.../fixtures/optional_fn_argument_pass_option.res:5:18 + + 3 │ let t = Some(1) + 4 │ + 5 │ let f = optFn(~x=t) + 6 │ + + This has type: option + But this optional function argument is expecting: int + + You're passing an optional value into an optional function argument. + Optional function arguments expect you to pass the concrete value, not an option, when passed directly. + + Possible solutions: + - Unwrap the option and pass a concrete value directly + - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: ?t \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/optional_fn_argument_pass_option.res b/tests/build_tests/super_errors/fixtures/optional_fn_argument_pass_option.res new file mode 100644 index 0000000000..fe9befffe5 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/optional_fn_argument_pass_option.res @@ -0,0 +1,5 @@ +let optFn = (~x: option=?) => x + +let t = Some(1) + +let f = optFn(~x=t) From 3e8a1f70c2321a1834462e22617b8b67579faf89 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 30 May 2025 20:42:23 +0200 Subject: [PATCH 10/17] format --- .../optional_record_field_pass_option.res.expected | 7 ++++--- .../fixtures/optional_record_field_pass_option.res | 6 ++---- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected index 59d59caa59..9f37e4d3fe 100644 --- a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -1,10 +1,11 @@ We've found a bug for you! - /.../fixtures/optional_record_field_pass_option.res:6:16 + /.../fixtures/optional_record_field_pass_option.res:4:16 - 4 │ let t = Some(true) + 2 │ let t = Some(true) + 3 │ + 4 │ let x = {test: t} 5 │ - 6 │ let x = {test: t} This has type: option But this record field test is expected to have type: bool diff --git a/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res b/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res index 0f12983909..0bc5949dba 100644 --- a/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res +++ b/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res @@ -1,6 +1,4 @@ -type record = { - test?: bool -} +type record = {test?: bool} let t = Some(true) -let x = {test: t} \ No newline at end of file +let x = {test: t} From bb358aec7affca3a60395bde418b90897d1e4b3b Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Fri, 30 May 2025 21:05:11 +0200 Subject: [PATCH 11/17] cleanup --- compiler/ml/typecore.ml | 12 ++---------- 1 file changed, 2 insertions(+), 10 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 5691858afb..4c2b46ac53 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2570,7 +2570,6 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected get_jsx_component_props ~extract_concrete_typedecl env ty_record p | None -> None in - (* React.fragmentProps, JSXDOM.domProps *) let jsx_component_error_info = get_jsx_component_error_info () in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" ty_record @@ -2925,8 +2924,6 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected let cty', force = Typetexp.transl_simple_type_delayed env sty' in let ty' = cty'.ctyp_type in if separate then begin_def (); - (* TODO: What should this be?*) - let type_clash_context = None in let arg = type_exp ~context:None env sarg in let gen = if separate then ( @@ -2936,10 +2933,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected (try unify_var env tv arg.exp_type with Unify trace -> raise - (Error - ( arg.exp_loc, - env, - Expr_type_clash {trace; context = type_clash_context} ))); + (Error (arg.exp_loc, env, Expr_type_clash {trace; context = None}))); gen) else true in @@ -3748,7 +3742,7 @@ and type_construct ~context env loc lid sarg ty_expected attrs = } in (* Forward context if this is a Some constructor injected (meaning it's - an optional field or an optional argument) *) + an optional field) *) let context = match lid.txt with | Longident.Ldot (Lident "*predef*", "Some") -> ( @@ -3757,8 +3751,6 @@ and type_construct ~context env loc lid sarg ty_expected attrs = Some (Error_message_utils.RecordField {record_type; jsx; field_name; optional = true}) - | Some (FunctionArgument _) -> - Some (Error_message_utils.FunctionArgument {optional = true}) | _ -> None) | _ -> None in From 28a3d38c285484f8c0bc7bb3c95ac251b9aab7a4 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 2 Jun 2025 17:37:22 +0200 Subject: [PATCH 12/17] PR comments --- compiler/ml/error_message_utils.ml | 48 ++++++++++++------- compiler/ml/typecore.ml | 14 +++++- ...line_types_record_type_params.res.expected | 2 +- ...jsx_custom_component_children.res.expected | 2 +- ...jsx_custom_component_optional.res.expected | 2 +- .../jsx_type_mismatch_float.res.expected | 2 +- .../jsx_type_mismatch_int.res.expected | 2 +- .../jsx_type_mismatch_string.res.expected | 2 +- ...ional_fn_argument_pass_option.res.expected | 6 +-- ...onal_record_field_pass_option.res.expected | 6 +-- .../set_record_field_type_match.res.expected | 2 +- 11 files changed, 56 insertions(+), 32 deletions(-) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index af225d7a5a..96b36f7bba 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -99,7 +99,7 @@ type type_clash_context = operator: string; is_constant: string option; } - | FunctionArgument of {optional: bool} + | FunctionArgument of {optional: bool; name: string option} | Statement of type_clash_statement | ForLoopCondition @@ -138,11 +138,17 @@ let error_type_text ppf type_clash_context = let error_expected_type_text ppf type_clash_context = match type_clash_context with - | Some (FunctionArgument {optional}) -> - fprintf ppf "But this%s function argument is expecting:" + | Some (FunctionArgument {optional; name}) -> + fprintf ppf "But this%s function argument" (match optional with | false -> "" - | true -> " optional") + | true -> " optional"); + + (match name with + | Some name -> fprintf ppf " @{~%s@}" name + | None -> ()); + + fprintf ppf " is expecting:" | Some ComparisonOperator -> fprintf ppf "But it's being compared to something of type:" | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:" @@ -158,21 +164,21 @@ let error_expected_type_text ppf type_clash_context = fprintf ppf "But this @{if@} statement is expected to return:" | Some ArrayValue -> fprintf ppf "But this array is expected to have items of type:" - | Some (SetRecordField _) -> fprintf ppf "But this record field is of type:" + | Some (SetRecordField _) -> fprintf ppf "But the record field is of type:" | Some (RecordField {field_name = "children"; jsx = Some {jsx_type = `Fragment}}) -> - fprintf ppf "But children of JSX fragments is expected to have type:" + fprintf ppf "But children of JSX fragments are expected to have type:" | Some (RecordField {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) -> fprintf ppf - "But children passed to this component is expected to have type:" + "But children passed to this component are expected to have type:" | Some (RecordField {field_name; jsx = Some _}) -> - fprintf ppf "But this component prop @{%s@} is expected to have type:" + fprintf ppf "But the component prop @{%s@} is expected to have type:" field_name | Some (RecordField {field_name}) -> - fprintf ppf "But this record field @{%s@} is expected to have type:" + fprintf ppf "But the record field @{%s@} is expected to have type:" field_name | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:" | Some (MathOperator {operator}) -> @@ -429,9 +435,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @,\ @{%s@} is an optional record field, and you're passing an \ optional value to it.@,\ - Optional fields expect you to pass the concrete value, not an option, \ - when passed directly.\n\ - \ @,\ + Optional fields expect you to pass the concrete value, not an option.\n\ + \ @,\ Possible solutions: @,\ - Unwrap the option and pass a concrete value directly@,\ - If you really do want to pass the optional value, prepend the value \ @@ -447,8 +452,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @,\ You're passing an optional value into an optional function argument.@,\ Optional function arguments expect you to pass the concrete value, not \ - an option, when passed directly.\n\ - \ @,\ + an option.\n\ + \ @,\ Possible solutions: @,\ - Unwrap the option and pass a concrete value directly@,\ - If you really do want to pass the optional value, prepend the value \ @@ -510,9 +515,9 @@ let type_clash_context_from_function sexp sfunct = Some (MathOperator {for_float = true; operator; is_constant}) | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} -> Some (MathOperator {for_float = false; operator; is_constant}) - | _ -> Some (FunctionArgument {optional = false}) + | _ -> None -let type_clash_context_for_function_argument type_clash_context sarg0 = +let type_clash_context_for_function_argument ~label type_clash_context sarg0 = match type_clash_context with | Some (MathOperator {for_float; operator}) -> Some @@ -527,7 +532,16 @@ let type_clash_context_for_function_argument type_clash_context sarg0 = Some txt | _ -> None); }) - | None -> Some (FunctionArgument {optional = false}) + | None -> + Some + (FunctionArgument + { + optional = false; + name = + (match label with + | Asttypes.Nolabel -> None + | Optional {txt = l} | Labelled {txt = l} -> Some l); + }) | type_clash_context -> type_clash_context let type_clash_context_maybe_option ty_expected ty_res = diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 4c2b46ac53..33a7965a62 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3647,12 +3647,22 @@ and type_application ~context total_app env funct (sargs : sargs) : (if (not optional) || is_optional_loc l' then fun () -> type_argument ~context: - (type_clash_context_for_function_argument context sarg0) + (type_clash_context_for_function_argument ~label:l' context + sarg0) env sarg0 ty ty0 else fun () -> option_some (type_argument - ~context:(Some (FunctionArgument {optional = true})) + ~context: + (Some + (FunctionArgument + { + optional = true; + name = + (match l' with + | Nolabel -> None + | Optional l | Labelled l -> Some l.txt); + })) env sarg0 (extract_option_type env ty) (extract_option_type env ty0))) ) diff --git a/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected index 7e304a17de..bf99a6fba7 100644 --- a/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected +++ b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected @@ -9,6 +9,6 @@ 15 ┆ otherExtra: Some({test: true, anotherInlined: {record: true}}), This has type: int - But this record field age is expected to have type: string + But the record field age is expected to have type: string You can convert int to string with Int.toString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected index 5f71bf3277..95b33b8ad0 100644 --- a/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected @@ -8,7 +8,7 @@ 25 │ This has type: float - But children passed to this component is expected to have type: + But children passed to this component are expected to have type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected index 317bac459d..b605e7c7f3 100644 --- a/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected @@ -8,6 +8,6 @@ 32 │ This has type: string - But this component prop someOpt is expected to have type: float + But the component prop someOpt is expected to have type: float You can convert string to float with Float.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected index 75096b66fd..4d3f800773 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: float - But children of JSX fragments is expected to have type: + But children of JSX fragments are expected to have type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected index 0c7bd8f665..23c82536cc 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: int - But children of JSX fragments is expected to have type: + But children of JSX fragments are expected to have type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert int to a JSX element with React.int. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected index bdf80bd0bb..edccb4c4c5 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: string - But children of JSX fragments is expected to have type: + But children of JSX fragments are expected to have type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert string to a JSX element with React.string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected index 68e129ba29..74b600cd6f 100644 --- a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected @@ -8,11 +8,11 @@ 6 │ This has type: option - But this optional function argument is expecting: int + But this optional function argument ~x is expecting: int You're passing an optional value into an optional function argument. - Optional function arguments expect you to pass the concrete value, not an option, when passed directly. - + Optional function arguments expect you to pass the concrete value, not an option. + Possible solutions: - Unwrap the option and pass a concrete value directly - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: ?t \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected index 9f37e4d3fe..385c84df2f 100644 --- a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -8,11 +8,11 @@ 5 │ This has type: option - But this record field test is expected to have type: bool + But the record field test is expected to have type: bool test is an optional record field, and you're passing an optional value to it. - Optional fields expect you to pass the concrete value, not an option, when passed directly. - + Optional fields expect you to pass the concrete value, not an option. + Possible solutions: - Unwrap the option and pass a concrete value directly - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: {test: ?t} \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/set_record_field_type_match.res.expected b/tests/build_tests/super_errors/expected/set_record_field_type_match.res.expected index fc634f630c..0e7e87d713 100644 --- a/tests/build_tests/super_errors/expected/set_record_field_type_match.res.expected +++ b/tests/build_tests/super_errors/expected/set_record_field_type_match.res.expected @@ -8,6 +8,6 @@ 12 │ You're assigning something to this field that has type: int - But this record field is of type: string + But the record field is of type: string You can convert int to string with Int.toString. \ No newline at end of file From 0ca45e7573aa216dd713e340d98eda783e840068 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 2 Jun 2025 17:49:02 +0200 Subject: [PATCH 13/17] update test output --- .../super_errors/expected/wrong_type_prop_punning.res.expected | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/build_tests/super_errors/expected/wrong_type_prop_punning.res.expected b/tests/build_tests/super_errors/expected/wrong_type_prop_punning.res.expected index 897bf7dce2..e07a69fed7 100644 --- a/tests/build_tests/super_errors/expected/wrong_type_prop_punning.res.expected +++ b/tests/build_tests/super_errors/expected/wrong_type_prop_punning.res.expected @@ -9,4 +9,4 @@ 23 │ } This has type: array - But it's expected to have type: float \ No newline at end of file + But the component prop someProp is expected to have type: float \ No newline at end of file From 33c4c2e47b964a1cdb1291058bd15427c19fec42 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 2 Jun 2025 19:02:54 +0200 Subject: [PATCH 14/17] change wording a bit --- compiler/ml/error_message_utils.ml | 10 ++++------ .../jsx_custom_component_children.res.expected | 2 +- .../expected/jsx_type_mismatch_float.res.expected | 2 +- .../expected/jsx_type_mismatch_int.res.expected | 2 +- .../expected/jsx_type_mismatch_string.res.expected | 2 +- .../optional_fn_argument_pass_option.res.expected | 2 +- .../optional_record_field_pass_option.res.expected | 2 +- 7 files changed, 10 insertions(+), 12 deletions(-) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 96b36f7bba..9eb9366e9e 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -168,12 +168,11 @@ let error_expected_type_text ppf type_clash_context = | Some (RecordField {field_name = "children"; jsx = Some {jsx_type = `Fragment}}) -> - fprintf ppf "But children of JSX fragments are expected to have type:" + fprintf ppf "But children of JSX fragments must be of type:" | Some (RecordField {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) -> - fprintf ppf - "But children passed to this component are expected to have type:" + fprintf ppf "But children passed to this component must be of type:" | Some (RecordField {field_name; jsx = Some _}) -> fprintf ppf "But the component prop @{%s@} is expected to have type:" field_name @@ -435,7 +434,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @,\ @{%s@} is an optional record field, and you're passing an \ optional value to it.@,\ - Optional fields expect you to pass the concrete value, not an option.\n\ + Optional fields expect you to pass a non-optional value.\n\ \ @,\ Possible solutions: @,\ - Unwrap the option and pass a concrete value directly@,\ @@ -451,8 +450,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf "@,\ @,\ You're passing an optional value into an optional function argument.@,\ - Optional function arguments expect you to pass the concrete value, not \ - an option.\n\ + Optional function arguments expect you to pass a non-optional value.\n\ \ @,\ Possible solutions: @,\ - Unwrap the option and pass a concrete value directly@,\ diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected index 95b33b8ad0..46b4d18188 100644 --- a/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_children.res.expected @@ -8,7 +8,7 @@ 25 │ This has type: float - But children passed to this component are expected to have type: + But children passed to this component must be of type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected index 4d3f800773..2244de59be 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: float - But children of JSX fragments are expected to have type: + But children of JSX fragments must be of type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert float to a JSX element with React.float. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected index 23c82536cc..8bcf5e984b 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_int.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: int - But children of JSX fragments are expected to have type: + But children of JSX fragments must be of type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert int to a JSX element with React.int. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected index edccb4c4c5..63d11ba4f8 100644 --- a/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected +++ b/tests/build_tests/super_errors/expected/jsx_type_mismatch_string.res.expected @@ -8,7 +8,7 @@ 18 │ This has type: string - But children of JSX fragments are expected to have type: + But children of JSX fragments must be of type: React.element (defined as Jsx.element) In JSX, all content must be JSX elements. You can convert string to a JSX element with React.string. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected index 74b600cd6f..a75ed921e9 100644 --- a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected @@ -11,7 +11,7 @@ But this optional function argument ~x is expecting: int You're passing an optional value into an optional function argument. - Optional function arguments expect you to pass the concrete value, not an option. + Optional function arguments expect you to pass a non-optional value. Possible solutions: - Unwrap the option and pass a concrete value directly diff --git a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected index 385c84df2f..2490aae9cf 100644 --- a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -11,7 +11,7 @@ But the record field test is expected to have type: bool test is an optional record field, and you're passing an optional value to it. - Optional fields expect you to pass the concrete value, not an option. + Optional fields expect you to pass a non-optional value. Possible solutions: - Unwrap the option and pass a concrete value directly From c29fc2343833b5ddea02d719ea7cdfa6062c6b6d Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 3 Jun 2025 10:43:04 +0200 Subject: [PATCH 15/17] change wording --- compiler/ml/error_message_utils.ml | 10 ++++++---- .../optional_fn_argument_pass_option.res.expected | 4 ++-- .../optional_record_field_pass_option.res.expected | 4 ++-- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 9eb9366e9e..7a3a74ea23 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -434,10 +434,11 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @,\ @{%s@} is an optional record field, and you're passing an \ optional value to it.@,\ - Optional fields expect you to pass a non-optional value.\n\ + Values passed to an optional record field don't need to be wrapped in \ + an option. You might need to adjust the type of the value supplied.\n\ \ @,\ Possible solutions: @,\ - - Unwrap the option and pass a concrete value directly@,\ + - Unwrap the option from the value you're passing in@,\ - If you really do want to pass the optional value, prepend the value \ with @{?@} to show you want to pass the option, like: \ @{{%s: ?%s@}}" @@ -450,10 +451,11 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf "@,\ @,\ You're passing an optional value into an optional function argument.@,\ - Optional function arguments expect you to pass a non-optional value.\n\ + Values passed to an optional function argument don't need to be wrapped \ + in an option. You might need to adjust the type of the value supplied.\n\ \ @,\ Possible solutions: @,\ - - Unwrap the option and pass a concrete value directly@,\ + - Unwrap the option from the value you're passing in@,\ - If you really do want to pass the optional value, prepend the value \ with @{?@} to show you want to pass the option, like: \ @{?%s@}" diff --git a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected index a75ed921e9..61869d080c 100644 --- a/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_fn_argument_pass_option.res.expected @@ -11,8 +11,8 @@ But this optional function argument ~x is expecting: int You're passing an optional value into an optional function argument. - Optional function arguments expect you to pass a non-optional value. + Values passed to an optional function argument don't need to be wrapped in an option. You might need to adjust the type of the value supplied. Possible solutions: - - Unwrap the option and pass a concrete value directly + - Unwrap the option from the value you're passing in - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: ?t \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected index 2490aae9cf..2354449a6e 100644 --- a/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -11,8 +11,8 @@ But the record field test is expected to have type: bool test is an optional record field, and you're passing an optional value to it. - Optional fields expect you to pass a non-optional value. + Values passed to an optional record field don't need to be wrapped in an option. You might need to adjust the type of the value supplied. Possible solutions: - - Unwrap the option and pass a concrete value directly + - Unwrap the option from the value you're passing in - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: {test: ?t} \ No newline at end of file From f2d32784d4386e7b6e16850fd4a50b778afa1391 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 3 Jun 2025 10:44:25 +0200 Subject: [PATCH 16/17] changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index e3c86559c4..494bdd1932 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -39,6 +39,7 @@ - Improve a few error messages around various subtyping issues. https://github.com/rescript-lang/rescript/pull/7404 - In module declarations, accept the invalid syntax `M = {...}` and format it to `M : {...}`. https://github.com/rescript-lang/rescript/pull/7527 - Improve doc comment formatting to match the style of multiline comments. https://github.com/rescript-lang/rescript/pull/7529 +- Improve error messages around type mismatches for try/catch, if, for, while, and optional record fields + optional function arguments. https://github.com/rescript-lang/rescript/pull/7522 #### :house: Internal From 1171e1605316a5c30cfef4b494d166db8200ccd0 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Tue, 3 Jun 2025 11:01:23 +0200 Subject: [PATCH 17/17] explicit error message for optional component props, since they have another syntax --- compiler/ml/error_message_utils.ml | 20 ++++++++++- ...ustom_component_optional_prop.res.expected | 18 ++++++++++ ...ustom_component_type_mismatch.res.expected | 13 ++++++++ .../jsx_custom_component_optional_prop.res | 33 +++++++++++++++++++ ...=> jsx_custom_component_type_mismatch.res} | 0 5 files changed, 83 insertions(+), 1 deletion(-) create mode 100644 tests/build_tests/super_errors/expected/jsx_custom_component_optional_prop.res.expected create mode 100644 tests/build_tests/super_errors/expected/jsx_custom_component_type_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/jsx_custom_component_optional_prop.res rename tests/build_tests/super_errors/fixtures/{jsx_custom_component_optional.res => jsx_custom_component_type_mismatch.res} (100%) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 7a3a74ea23..27f30fe35d 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -426,7 +426,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf single JSX element.@," (with_configured_jsx_module "array") | _ -> ()) - | ( Some (RecordField {optional = true; field_name}), + | ( Some (RecordField {optional = true; field_name; jsx = None}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> fprintf ppf @@ -444,6 +444,24 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf @{{%s: ?%s@}}" field_name field_name (Parser.extract_text_at_loc loc) + | ( Some (RecordField {optional = true; field_name; jsx = Some _}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + @{%s@} is an optional component prop, and you're passing an \ + optional value to it.@,\ + Values passed to an optional component prop don't need to be wrapped in \ + an option. You might need to adjust the type of the value supplied.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option from the value you're passing in@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{%s=?%s@}" + field_name field_name + (Parser.extract_text_at_loc loc) | ( Some (FunctionArgument {optional = true}), Some ({desc = Tconstr (p, _, _)}, _) ) when Path.same Predef.path_option p -> diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_optional_prop.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_optional_prop.res.expected new file mode 100644 index 0000000000..334f245a49 --- /dev/null +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_optional_prop.res.expected @@ -0,0 +1,18 @@ + + We've found a bug for you! + /.../fixtures/jsx_custom_component_optional_prop.res:33:34 + + 31 │ let o = Some(1.) + 32 │ + 33 │ let x = + 34 │ + + This has type: option + But the component prop someOpt is expected to have type: float + + someOpt is an optional component prop, and you're passing an optional value to it. + Values passed to an optional component prop don't need to be wrapped in an option. You might need to adjust the type of the value supplied. + + Possible solutions: + - Unwrap the option from the value you're passing in + - If you really do want to pass the optional value, prepend the value with ? to show you want to pass the option, like: someOpt=?o \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/jsx_custom_component_type_mismatch.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_type_mismatch.res.expected new file mode 100644 index 0000000000..9db22a386a --- /dev/null +++ b/tests/build_tests/super_errors/expected/jsx_custom_component_type_mismatch.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/jsx_custom_component_type_mismatch.res:31:34-40 + + 29 │ } + 30 │ + 31 │ let x = + 32 │ + + This has type: string + But the component prop someOpt is expected to have type: float + + You can convert string to float with Float.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional_prop.res b/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional_prop.res new file mode 100644 index 0000000000..3c3b220fdb --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional_prop.res @@ -0,0 +1,33 @@ +@@config({ + flags: ["-bs-jsx", "4"], +}) + +module React = { + type element = Jsx.element + type componentLike<'props, 'return> = 'props => 'return + type component<'props> = Jsx.component<'props> + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + type fragmentProps = {children?: element} + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" + + external float: float => element = "%identity" +} + +module CustomComponent = { + @react.component + let make = (~someOpt=?) => { + React.float( + switch someOpt { + | Some(5.) => 1. + | _ => 2. + }, + ) + } +} + +let o = Some(1.) + +let x = diff --git a/tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res b/tests/build_tests/super_errors/fixtures/jsx_custom_component_type_mismatch.res similarity index 100% rename from tests/build_tests/super_errors/fixtures/jsx_custom_component_optional.res rename to tests/build_tests/super_errors/fixtures/jsx_custom_component_type_mismatch.res