try tracking record field type checking

Author: zth

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 @{<info>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 @{<info>%s@} is expected to have type:"
+      field_name
   | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:"
   | Some (MathOperator {operator}) ->
     fprintf ppf

compiler/ml/typecore.ml

@@ -2572,7 +2572,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
         (type_label_a_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)
@@ -2682,7 +2682,7 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected
         (type_label_a_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)
@@ -2761,7 +2761,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;
@@ -3293,7 +3293,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
@@ -3320,7 +3321,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;
@@ -3330,10 +3339,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

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.