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 diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 267ac6c0f6..27f30fe35d 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -69,23 +69,58 @@ 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 + | SetRecordField 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 + | AssertCondition | IfReturn - | Switch + | SwitchReturn + | TryReturn | StringConcat | ComparisonOperator + | WhileCondition | MathOperator of { for_float: bool; operator: string; is_constant: string option; } - | FunctionArgument + | FunctionArgument of {optional: bool; name: string option} | 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 (RecordField _) -> "RecordField" + | 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 @@ -95,7 +130,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 @@ -103,25 +138,55 @@ 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; name}) -> + fprintf ppf "But this%s function argument" + (match optional with + | false -> "" + | 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 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 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 AssertCondition -> fprintf ppf "But assertions must always be of type:" | Some IfReturn -> 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 must be of type:" + | Some + (RecordField + {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) -> + 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 + | Some (RecordField {field_name}) -> + 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}) -> fprintf ppf "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 +266,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\ @@ -355,6 +426,58 @@ 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; jsx = None}), + 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.@,\ + 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 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 (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 -> + fprintf ppf + "@,\ + @,\ + You're passing an optional value into an optional function argument.@,\ + 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 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@}" + (Parser.extract_text_at_loc loc) | _, Some (t1, t2) -> let is_subtype = try @@ -410,9 +533,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 + | _ -> 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 @@ -427,6 +550,16 @@ let type_clash_context_for_function_argument type_clash_context sarg0 = Some txt | _ -> None); }) + | 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 = @@ -468,11 +601,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") @@ -484,18 +612,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 5e1f411f90..33a7965a62 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 = @@ -1902,7 +1904,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 +1917,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 +2183,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 +2221,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 +2231,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 +2305,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 +2319,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 @@ -2392,17 +2397,17 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp 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 | 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 +2434,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 +2451,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 +2468,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 +2486,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 +2503,7 @@ 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 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 +2518,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:None env sarg ty ty0 in re { exp_desc = Texp_variant (l, Some arg); @@ -2523,7 +2531,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 { @@ -2558,16 +2570,18 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp get_jsx_component_props ~extract_concrete_typedecl env ty_record p | None -> None 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 true env (fun e k -> k - (type_label_exp 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 - 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 @@ -2588,7 +2602,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp Labels_missing { labels = labels_missing; - jsx_component_info = get_jsx_component_error_info (); + jsx_component_info = jsx_component_error_info; } )); ([||], representation) | [], _ -> @@ -2621,7 +2635,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp 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 @@ -2640,7 +2654,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_exp ~context:None ~recarg env sexp in let ty_record, opath = let get_path ty = try @@ -2667,16 +2681,18 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp 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 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 - 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 @@ -2735,7 +2752,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | Pexp_field (srecord, lid) -> let record, label, _ = type_label_access 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); @@ -2749,10 +2766,10 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp 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 ~type_clash_context:SetRecordField false env loc ty_record + type_label_exp ~call_context:`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 +2786,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 +2803,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 +2820,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 +2834,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:None env sexp2 ty_expected in re { exp_desc = Texp_sequence (exp1, exp2); @@ -2833,8 +2846,10 @@ 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 = + type_expect ~context:(Some WhileCondition) env scond Predef.type_bool + in + let body = type_statement ~context:None env sbody in rue { exp_desc = Texp_while (cond, body); @@ -2845,8 +2860,12 @@ 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 + 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) @@ -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,7 @@ 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 + let arg = type_exp ~context:None env sarg in let gen = if separate then ( end_def (); @@ -2913,8 +2933,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp (try unify_var env tv arg.exp_type with Unify trace -> raise - (Error - (arg.exp_loc, env, Expr_type_clash (trace, type_clash_context)))); + (Error (arg.exp_loc, env, Expr_type_clash {trace; context = None}))); gen) else true in @@ -2953,7 +2972,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 +3029,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 +3054,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 +3065,9 @@ 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 + 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 @@ -3087,7 +3108,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 +3157,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 = @@ -3188,7 +3209,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:None loc env fun_t ty_expected_; fun_t in let loc_fun, ty_fun = @@ -3220,8 +3241,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 @@ -3244,7 +3265,7 @@ and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l } and type_label_access env srecord lid = - let record = type_exp ~recarg:Allowed env srecord in + let record = type_exp ~context:None ~recarg:Allowed env srecord in let ty_exp = record.exp_type in let opath = try @@ -3272,7 +3293,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 +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 (); @@ -3300,8 +3321,17 @@ 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 field_name = Longident.last lid.txt in + let field_context = + match call_context with + | `SetRecordField -> Some (Error_message_utils.SetRecordField field_name) + | `Regular jsx -> + Some + (Error_message_utils.RecordField + {jsx; record_type = ty_expected; field_name; optional = false}) + in let arg = - type_argument ?type_clash_context env sarg ty_arg (instance env ty_arg) + type_argument ~context:field_context env sarg ty_arg (instance env ty_arg) in end_def (); try @@ -3312,10 +3342,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:field_context env sarg in end_def (); generalize_expansive env arg.exp_type; - unify_exp 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 @@ -3324,10 +3354,9 @@ 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 @@ -3340,7 +3369,7 @@ and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) 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 +3395,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 +3462,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 +3613,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 +3646,29 @@ 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 ~label:l' context + sarg0) env sarg0 ty ty0 else fun () -> option_some - (type_argument ?type_clash_context env sarg0 + (type_argument + ~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))) ) 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 +3682,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 +3693,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 +3704,7 @@ 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 = let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -3705,11 +3751,23 @@ 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 + (* Forward context if this is a Some constructor injected (meaning it's + an optional field) *) + 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}) + | _ -> None) + | _ -> None + 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 +3779,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 +3797,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 +3808,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 @@ -3875,18 +3932,18 @@ and type_cases ?root_type_clash_context ?in_function env ty_arg ty_res | None -> None | Some scond -> 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 +3954,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 +3979,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 +4117,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 +4175,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 +4277,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/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 new file mode 100644 index 0000000000..d00bebec45 --- /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:15-18 + + 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/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/inline_types_record_type_params.res.expected b/tests/build_tests/super_errors/expected/inline_types_record_type_params.res.expected index 8a69447541..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 it's 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 new file mode 100644 index 0000000000..46b4d18188 --- /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 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_custom_component_optional.res.expected b/tests/build_tests/super_errors/expected/jsx_custom_component_optional.res.expected new file mode 100644 index 0000000000..b605e7c7f3 --- /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 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_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/expected/jsx_type_mismatch_float.res.expected b/tests/build_tests/super_errors/expected/jsx_type_mismatch_float.res.expected index af4279bd52..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,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 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 5a43157d03..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,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 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 10d1d64dc7..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,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 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 new file mode 100644 index 0000000000..61869d080c --- /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 ~x is expecting: int + + You're passing an optional value into an optional function argument. + 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 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 new file mode 100644 index 0000000000..2354449a6e --- /dev/null +++ b/tests/build_tests/super_errors/expected/optional_record_field_pass_option.res.expected @@ -0,0 +1,18 @@ + + We've found a bug for you! + /.../fixtures/optional_record_field_pass_option.res:4:16 + + 2 │ let t = Some(true) + 3 │ + 4 │ let x = {test: t} + 5 │ + + This has type: option + 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. + 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 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 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 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/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/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 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") 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) +} 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/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_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_type_mismatch.res b/tests/build_tests/super_errors/fixtures/jsx_custom_component_type_mismatch.res new file mode 100644 index 0000000000..58759ac7e8 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/jsx_custom_component_type_mismatch.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_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) 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..0bc5949dba --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/optional_record_field_pass_option.res @@ -0,0 +1,4 @@ +type record = {test?: bool} +let t = Some(true) + +let x = {test: t} 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" +} 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") +}