[WIP] Rework impl/interface error messages

jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected

@@ -11,12 +11,11 @@
 
   Signature mismatch:
   ...
-  Type declarations do not match:
-    type t<'a, 'b, 'c> = {x: int, y: list<('a, 'c)>, z: int}
-  is not included in
-    type t<'a, 'b, 'c> = {x: int, y: list<('a, 'b)>, z: int}
+  The type of type t differs between interface and implementation.
+
+  - Field y has type list<('a, 'c)> in the implementation, but should have type list<('a0, 'b)> according to the interface
+
   /.../fixtures/RecordInclusion.res:2:3-55:
-    Expected declaration
+    Interface
   /.../fixtures/RecordInclusion.res:4:3-55:
-    Actual declaration
-  The types for field y are not equal.
+    Implementation

jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected

@@ -9,21 +9,13 @@
   5 │ }
 
   Signature mismatch:
-  Modules do not match:
-    {
-  type t = @as(null) A
-}
-  is not included in
-    {
-  @unboxed type t = @as(null) A
-}
-  Type declarations do not match:
-    type t = @as(null) A
-  is not included in
-    @unboxed type t = @as(null) A
+  Module implementation differs from its interface.
+
+  The type of type t differs between interface and implementation.
+
+  - Their internal representations differ: the interface declaration uses unboxed representation
+
   /.../fixtures/UntaggedImplIntf.res:2:12-33:
-    Expected declaration
+    Interface
   /.../fixtures/UntaggedImplIntf.res:4:3-24:
-    Actual declaration
-  Their internal representations differ:
-  the second declaration uses unboxed representation.
+    Implementation

jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_arg_type.res.expected

@@ -0,0 +1,22 @@
+
+  We've found a bug for you!
+  /.../fixtures/interface_impl_mismatch_fn_arg_type.res:7:5-10:1
+
+   5 │   }
+   6 │   let make: (~name: string, ~age: int) => x
+   7 │ } = {
+   8 │   type x = {name: string, age: int}
+   9 │   let make = (~name, ~age) => {name, age: age->int_of_float}
+  10 │ }
+  11 │ 
+
+  Signature mismatch:
+  ...
+  Value make does not have the same type in the implementation and interface.
+
+  Argument age is float in the implementation, but according to the interface it should be int 
+
+  /.../fixtures/interface_impl_mismatch_fn_arg_type.res:6:3-43:
+    Interface
+  /.../fixtures/interface_impl_mismatch_fn_arg_type.res:9:7-10:
+    Implementation

jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_return_type.res.expected

@@ -0,0 +1,22 @@
+
+  We've found a bug for you!
+  /.../fixtures/interface_impl_mismatch_fn_return_type.res:7:5-10:1
+
+   5 │   }
+   6 │   let make: int => string
+   7 │ } = {
+   8 │   type x = {name: string, age: int}
+   9 │   let make = s => {name: "", age: s}
+  10 │ }
+  11 │ 
+
+  Signature mismatch:
+  ...
+  Value make does not have the same type in the implementation and interface.
+
+  Function returns type x in the implementation, but according to the interface it should be string 
+
+  /.../fixtures/interface_impl_mismatch_fn_return_type.res:6:3-25:
+    Interface
+  /.../fixtures/interface_impl_mismatch_fn_return_type.res:9:7-10:
+    Implementation

jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_arg_type.res

@@ -0,0 +1,10 @@
+module X: {
+  type x = {
+    name: string,
+    age: int,
+  }
+  let make: (~name: string, ~age: int) => x
+} = {
+  type x = {name: string, age: int}
+  let make = (~name, ~age) => {name, age: age->int_of_float}
+}

jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_return_type.res

@@ -0,0 +1,10 @@
+module X: {
+  type x = {
+    name: string,
+    age: int,
+  }
+  let make: int => string
+} = {
+  type x = {name: string, age: int}
+  let make = s => {name: "", age: s}
+}

jscomp/ml/ctype.ml

@@ -52,6 +52,16 @@ open Btype
      policy can then be easily changed.
 *)
 
+type unify_context = FunctionArgument of arg_label| Debug of string | FunctionReturnType
+
+let unify_context = ref None
+
+let set_unify_context (s: unify_context) = unify_context := Some s
+
+let unset_unify_context () = unify_context := None
+
+let get_unify_context () = !unify_context
+
 (**** Errors ****)
 
 exception Unify of (type_expr * type_expr) list
@@ -2345,7 +2355,11 @@ and unify3 env t1 t1' t2 t2' =
         (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when Asttypes.same_arg_label l1  l2 ||
         (!umode = Pattern) &&
         not (is_optional l1 || is_optional l2) ->
-          unify  env t1 t2; unify env  u1 u2;
+          set_unify_context (FunctionArgument l1);
+          unify env t1 t2; 
+          set_unify_context (FunctionReturnType); 
+          unify env  u1 u2;
+          unset_unify_context ();
           begin match commu_repr c1, commu_repr c2 with
             Clink r, c2 -> set_commu r c2
           | c1, Clink r -> set_commu r c1

jscomp/ml/ctype.mli

@@ -18,6 +18,10 @@
 open Asttypes
 open Types
 
+type unify_context = FunctionArgument of arg_label| Debug of string | FunctionReturnType
+
+val get_unify_context: unit -> unify_context option
+
 exception Unify of (type_expr * type_expr) list
 exception Tags of label * label
 exception Subtype of

jscomp/ml/error_message_utils.ml

@@ -295,4 +295,24 @@ let get_jsx_component_error_info ~extract_concrete_typedecl opath env ty_record
   match opath with
   | Some (p, _) ->
     get_jsx_component_props ~extract_concrete_typedecl env ty_record p
-  | None -> None
+  | None -> None
+
+let diff_type_exprs ppf env t1 t2 = 
+  try
+    Ctype.unify env t1 t2;
+  with
+    Ctype.Unify (trace) ->
+      let ctx = Ctype.get_unify_context () in
+      (match ctx with 
+      | Some (Debug s) -> fprintf ppf "DEBUG: %s @\n@\n" s 
+      | _ -> ());
+      let prefix = (fun ppf -> match ctx with 
+      | Some (FunctionArgument Nolabel) -> fprintf ppf "Unlabelled argument is" 
+      | Some (FunctionArgument (Labelled s | Optional s)) -> fprintf ppf "Argument @{<info>%s@} is" s
+      | Some (FunctionReturnType) -> fprintf ppf "Function returns type"
+      | _ -> fprintf ppf "Type") in
+      Printtyp.report_unification_error2 prefix ppf Env.empty trace
+        (fun ppf ->
+           fprintf ppf "This type")
+        (fun ppf ->
+           fprintf ppf "should be an instance of type");

jscomp/ml/includecore.ml

@@ -125,43 +125,52 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
 (* Inclusion between type declarations *)
 
 type type_mismatch =
-    Arity
+    Arity of {left_arity: int; right_arity: int}
   | Privacy
   | Kind
   | Constraint
   | Manifest
   | Variance
-  | Field_type of Ident.t
-  | Field_mutable of Ident.t
+  | Field_type of {field_name: Ident.t; left_field: Types.label_declaration; right_field: Types.label_declaration}
+  | Constructor_type of Ident.t
+  | Field_mutable of {field_name: Ident.t; left_is_mutable: bool}
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t
   | Record_representation of record_representation * record_representation
   | Unboxed_representation of bool  (* true means second one is unboxed *)
   | Immediate
-  | Tag_name
+  | Tag_name of {left_value: string option; right_value: string option} 
   | Variant_representation of Ident.t
 
 let report_type_mismatch0 first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
   match err with
-    Arity -> pr "They have different arities"
+    Arity {left_arity; right_arity} -> pr "It has @{<error>%i@} type parameters in the implementation and @{<info>%i@} in the interface." left_arity right_arity
   | Privacy -> pr "A private type would be revealed"
   | Kind -> pr "Their kinds differ"
   | Constraint -> pr "Their constraints differ"
   | Manifest -> ()
   | Variance -> pr "Their variances do not agree"
-  | Field_type s ->
-      pr "The types for field %s are not equal" (Ident.name s)
-  | Field_mutable s ->
-      pr "The mutability of field %s is different" (Ident.name s)
+  | Constructor_type field_name ->
+      pr "The types for field %s are not equal" (Ident.name field_name)
+  | Field_type {field_name; left_field; right_field} ->
+      pr "Field @{<info>%s@} has type @{<error>%a@} in the implementation, but should have type @{<info>%a@} according to the interface" 
+      (Ident.name field_name)
+      Printtyp.type_expr left_field.ld_type
+      Printtyp.type_expr right_field.ld_type
+  | Field_mutable {field_name; left_is_mutable} ->
+      pr "Field @{<info>%s@} is @{<error>%s@} in the implementation, but @{<info>%s@} in the interface" 
+      (Ident.name field_name)
+      (if left_is_mutable then "mutable" else "immutable")
+      (if left_is_mutable then "immutable" else "mutable")
   | Field_arity s ->
       pr "The arities for field %s differ" (Ident.name s)
   | Field_names (n, name1, name2) ->
-      pr "Fields number %i have different names, %s and %s"
+      pr "Field number @{<info>%i@} is named @{<error>%s@} in the implementation but @{<info>%s@} in the interface. Fields must be ordered the same in interface and implementation."
         n name1 name2
   | Field_missing (b, s) ->
-      pr "The field %s is only present in %s %s"
+      pr "Field @{<info>%s@} is only present in %s %s"
         (Ident.name s) (if b then second else first) decl
   | Record_representation (rep1, rep2) ->
       let default () = pr "Their internal representations differ" in
@@ -181,19 +190,22 @@ let report_type_mismatch0 first second decl ppf err =
           default ()
       )
   | Unboxed_representation b ->
-      pr "Their internal representations differ:@ %s %s %s"
+      pr "Their internal representations differ: %s %s %s"
          (if b then second else first) decl
          "uses unboxed representation"
   | Immediate -> pr "%s is not an immediate type" first
-  | Tag_name -> pr "Their @tag annotations differ"
+  | Tag_name {left_value; right_value} -> 
+    pr "@{<info>@tag@} annotations differ. It is @{<error>%s@} in the implementation but @{<info>%s@} in the interface." 
+    (match left_value with None -> "not set" | Some s -> "\"" ^ s ^ "\"")
+    (match right_value with None -> "not set" | Some s -> "\"" ^ s ^ "\"")
   | Variant_representation s ->
     pr "The internal representations for case %s are not equal" (Ident.name s)
 
 let report_type_mismatch first second decl ppf =
   List.iter
     (fun err ->
       if err = Manifest then () else
-      Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
+      Format.fprintf ppf "@ - %a" (report_type_mismatch0 first second decl) err)
 
 let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
   match arg1, arg2 with
@@ -202,10 +214,10 @@ let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
       else if
         (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
         Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
-      then [] else [Field_type cstr]
+      then [] else [Constructor_type cstr]
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
       compare_records env ~loc params1 params2 0 l1 l2
-  | _ -> [Field_type cstr]
+  | _ -> [Constructor_type cstr]
 
 and compare_variants ~loc env params1 params2 n
     (cstrs1 : Types.constructor_declaration list)
@@ -230,9 +242,9 @@ and compare_variants ~loc env params1 params2 n
               if Ctype.equal env true [r1] [r2] then
                 compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2]
                   cd1.cd_args cd2.cd_args
-              else [Field_type cd1.cd_id]
+              else [Constructor_type cd1.cd_id]
           | Some _, None | None, Some _ ->
-              [Field_type cd1.cd_id]
+              [Constructor_type cd1.cd_id]
           | _ ->
               compare_constructor_arguments ~loc env cd1.cd_id
                 params1 params2 cd1.cd_args cd2.cd_args
@@ -272,7 +284,7 @@ and compare_records ~loc env params1_ params2_ n_
     | ld1::rem1, ld2::rem2 ->
         if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
         then [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)]
-        else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else begin
+        else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable {field_name=ld1.ld_id; left_is_mutable = ld1.ld_mutable = Mutable}] else begin
           Builtin_attributes.check_deprecated_mutable_inclusion
             ~def:ld1.ld_loc
             ~use:ld2.ld_loc
@@ -295,7 +307,7 @@ and compare_records ~loc env params1_ params2_ n_
               (n+1)
               rem1 rem2
           else
-            [Field_type ld1.ld_id]
+            [Field_type {field_name=ld1.ld_id; left_field=ld1; right_field=ld2}]
       end in
   aux ~fast:true params1_ params2_ n_ labels1_ labels2_
 
@@ -307,7 +319,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
     loc
     decl1.type_attributes decl2.type_attributes
     name;
-  if decl1.type_arity <> decl2.type_arity then [Arity] else
+  if decl1.type_arity <> decl2.type_arity then [Arity {left_arity = decl1.type_arity; right_arity = decl2.type_arity}] else
   if not (private_flags decl1 decl2) then [Privacy] else
   let err = match (decl1.type_manifest, decl2.type_manifest) with
       (_, None) ->
@@ -341,7 +353,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 =
   let err =
     let tag1 = Ast_untagged_variants.process_tag_name decl1.type_attributes in
     let tag2 = Ast_untagged_variants.process_tag_name decl2.type_attributes in
-    if tag1 <> tag2 then [Tag_name] else err in
+    if tag1 <> tag2 then [Tag_name {left_value = tag1; right_value = tag2}] else err in
   if err <> [] then err else
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []

jscomp/ml/includecore.mli

@@ -21,21 +21,22 @@ open Types
 exception Dont_match
 
 type type_mismatch =
-    Arity
+    Arity of {left_arity: int; right_arity: int}
   | Privacy
   | Kind
   | Constraint
   | Manifest
   | Variance
-  | Field_type of Ident.t
-  | Field_mutable of Ident.t
+  | Field_type of {field_name: Ident.t; left_field: Types.label_declaration; right_field: Types.label_declaration}
+  | Constructor_type of Ident.t
+  | Field_mutable of {field_name: Ident.t; left_is_mutable: bool}
   | Field_arity of Ident.t
   | Field_names of int * string * string
   | Field_missing of bool * Ident.t
   | Record_representation of record_representation * record_representation
   | Unboxed_representation of bool
   | Immediate
-  | Tag_name
+  | Tag_name of {left_value: string option; right_value: string option} 
   | Variant_representation of Ident.t
 
 val value_descriptions: