From 0863f4e709dfe7ed1262873ff65c6d2acdede921 Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Sun, 15 Sep 2024 22:16:19 +0200 Subject: [PATCH 1/2] start reworking impl/interface error messages --- .../expected/RecordInclusion.res.expected | 13 ++--- .../expected/UntaggedImplIntf.res.expected | 24 +++----- jscomp/ml/includecore.ml | 56 +++++++++++-------- jscomp/ml/includecore.mli | 9 +-- jscomp/ml/includemod.ml | 24 +++----- jscomp/ml/typedecl.ml | 4 +- 6 files changed, 64 insertions(+), 66 deletions(-) diff --git a/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected b/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected index 7f3f6db28a..7e8f10faad 100644 --- a/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected +++ b/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. \ No newline at end of file + Implementation \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected index ffdcb9713f..95dd386855 100644 --- a/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected +++ b/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. \ No newline at end of file + Implementation \ No newline at end of file diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml index d68d0546eb..1b01ca79e4 100644 --- a/jscomp/ml/includecore.ml +++ b/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 @{%i@} type parameters in the implementation and @{%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 @{%s@} has type @{%a@} in the implementation, but should have type @{%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 @{%s@} is @{%s@} in the implementation, but @{%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 @{%i@} is named @{%s@} in the implementation but @{%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 @{%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,11 +190,14 @@ 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 "@{@tag@} annotations differ. It is @{%s@} in the implementation but @{%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) @@ -193,7 +205,7 @@ 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) -> [] diff --git a/jscomp/ml/includecore.mli b/jscomp/ml/includecore.mli index 2908a07b3c..829e3a4ad6 100644 --- a/jscomp/ml/includecore.mli +++ b/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: diff --git a/jscomp/ml/includemod.ml b/jscomp/ml/includemod.ml index 4f02122d90..d3a70d8253 100644 --- a/jscomp/ml/includemod.ml +++ b/jscomp/ml/includemod.ml @@ -513,8 +513,8 @@ let show_loc msg ppf loc = fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg let show_locs ppf (loc1, loc2) = - show_loc "Expected declaration" ppf loc2; - show_loc "Actual declaration" ppf loc1 + show_loc "Interface" ppf loc2; + show_loc "Implementation" ppf loc1 let include_err ~env ppf = function | Missing_field (id, loc, kind) -> @@ -530,18 +530,15 @@ let include_err ~env ppf = function | _ -> ("", "") in fprintf ppf - "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" + "@[Values does not have the same type:@ %a%s@;<1 -2>is not included in@ %a%s@]" (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2; show_locs ppf (d1.val_loc, d2.val_loc); | Type_declarations(id, d1, d2, errs) -> - fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" - "Type declarations do not match" - (type_declaration id) d1 - "is not included in" - (type_declaration id) d2 - show_locs (d1.type_loc, d2.type_loc) + fprintf ppf "@[@[The type of type @{%s@} differs between interface and implementation.@\n@]%a@\n%a@]" + (Ident.name id) (Includecore.report_type_mismatch - "the first" "the second" "declaration") errs + "the implementation" "the interface" "declaration") errs + show_locs (d1.type_loc, d2.type_loc) | Extension_constructors(id, x1, x2) -> fprintf ppf "@[Extension declarations do not match:@ \ @@ -549,12 +546,9 @@ let include_err ~env ppf = function (extension_constructor id) x1 (extension_constructor id) x2; show_locs ppf (x1.ext_loc, x2.ext_loc) - | Module_types(mty1, mty2)-> + | Module_types(_mty1, _mty2)-> fprintf ppf - "@[Modules do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - modtype mty1 - modtype mty2 + "@[Module implementation differs from its interface.@]@\n" | Modtype_infos(id, d1, d2) -> fprintf ppf "@[Module type declarations do not match:@ \ diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index bddd81d685..3ddf6f6b88 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -746,7 +746,7 @@ let check_coherence env loc id decl = let decl' = Env.find_type path env in let err = if List.length args <> List.length decl.type_params - then [Includecore.Arity] + then [Includecore.Arity {left_arity = List.length args; right_arity = List.length decl.type_params}] else if not (Ctype.equal env false args decl.type_params) then [Includecore.Constraint] else @@ -1615,7 +1615,7 @@ let transl_type_extension extend env loc styext = in let err = if type_decl.type_arity <> List.length styext.ptyext_params then - [Includecore.Arity] + [Includecore.Arity {left_arity = type_decl.type_arity; right_arity = List.length styext.ptyext_params}] else if List.for_all2 (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) From 676a302ac2a77d514450b1bb318a9890df5b4aae Mon Sep 17 00:00:00 2001 From: Gabriel Nordeborn Date: Mon, 16 Sep 2024 20:58:22 +0200 Subject: [PATCH 2/2] explore tracking context for unification --- ...ace_impl_mismatch_fn_arg_type.res.expected | 22 ++++++++++ ..._impl_mismatch_fn_return_type.res.expected | 22 ++++++++++ .../interface_impl_mismatch_fn_arg_type.res | 10 +++++ ...interface_impl_mismatch_fn_return_type.res | 10 +++++ jscomp/ml/ctype.ml | 16 +++++++- jscomp/ml/ctype.mli | 4 ++ jscomp/ml/error_message_utils.ml | 22 +++++++++- jscomp/ml/includemod.ml | 10 +++-- jscomp/ml/printtyp.ml | 41 +++++++++++++++++++ jscomp/ml/printtyp.mli | 5 +++ 10 files changed, 157 insertions(+), 5 deletions(-) create mode 100644 jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_arg_type.res.expected create mode 100644 jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_return_type.res.expected create mode 100644 jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_arg_type.res create mode 100644 jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_return_type.res diff --git a/jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_arg_type.res.expected b/jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_arg_type.res.expected new file mode 100644 index 0000000000..506f50b39b --- /dev/null +++ b/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 \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_return_type.res.expected b/jscomp/build_tests/super_errors/expected/interface_impl_mismatch_fn_return_type.res.expected new file mode 100644 index 0000000000..88d4f7ca6f --- /dev/null +++ b/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 \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_arg_type.res b/jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_arg_type.res new file mode 100644 index 0000000000..465d731f7f --- /dev/null +++ b/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} +} diff --git a/jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_return_type.res b/jscomp/build_tests/super_errors/fixtures/interface_impl_mismatch_fn_return_type.res new file mode 100644 index 0000000000..1db71e086a --- /dev/null +++ b/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} +} diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml index 950a1a598f..f725bfddb8 100644 --- a/jscomp/ml/ctype.ml +++ b/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 diff --git a/jscomp/ml/ctype.mli b/jscomp/ml/ctype.mli index 0fae1711bd..3cc62e78ae 100644 --- a/jscomp/ml/ctype.mli +++ b/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 diff --git a/jscomp/ml/error_message_utils.ml b/jscomp/ml/error_message_utils.ml index d178f2129f..bca118853d 100644 --- a/jscomp/ml/error_message_utils.ml +++ b/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 \ No newline at end of file + | 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 @{%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"); \ No newline at end of file diff --git a/jscomp/ml/includemod.ml b/jscomp/ml/includemod.ml index d3a70d8253..c1e1c0d791 100644 --- a/jscomp/ml/includemod.ml +++ b/jscomp/ml/includemod.ml @@ -521,7 +521,8 @@ let include_err ~env ppf = function fprintf ppf "The %s `%a' is required but not provided" kind ident id; show_loc "Expected declaration" ppf loc | Value_descriptions(id, d1, d2) -> - let curry_kind_1, curry_kind_2 = + (* TODO: Still need to incorporate this check? *) + let _curry_kind_1, _curry_kind_2 = match (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type ) with | { desc = Tarrow _ }, { desc = Tconstr (Pident {name = "function$"},_,_)} -> (" (curried)", " (uncurried)") @@ -530,8 +531,11 @@ let include_err ~env ppf = function | _ -> ("", "") in fprintf ppf - "@[Values does not have the same type:@ %a%s@;<1 -2>is not included in@ %a%s@]" - (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2; + "@[Value @{%s@} does not have the same type in the implementation and interface.@]" + (Ident.name id); + fprintf ppf "@\n"; + Error_message_utils.diff_type_exprs ppf env d1.val_type d2.val_type; + fprintf ppf "@\n"; show_locs ppf (d1.val_loc, d2.val_loc); | Type_declarations(id, d1, d2, errs) -> fprintf ppf "@[@[The type of type @{%s@} differs between interface and implementation.@\n@]%a@\n%a@]" diff --git a/jscomp/ml/printtyp.ml b/jscomp/ml/printtyp.ml index 41664610f1..af38d9e87c 100644 --- a/jscomp/ml/printtyp.ml +++ b/jscomp/ml/printtyp.ml @@ -1222,6 +1222,15 @@ let rec trace fst txt ppf = function (trace false txt) rem | _ -> () +let rec trace2 prefix fst txt ppf = function +| (t1, t1') :: (t2, t2') :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[%t @{%a@} %s @{%a@}@] %a" + prefix + (type_expansion t1) t1' txt (type_expansion t2) t2' + (trace2 prefix false txt) rem +| _ -> () + let rec filter_trace keep_last = function | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> [] @@ -1426,11 +1435,43 @@ let unification_error env unif tr txt1 ppf txt2 = with exn -> raise exn +let unification_error2 prefix env unif tr (_txt1: (formatter -> unit)) ppf (_txt2: (formatter -> unit)) = + reset (); + trace_same_names tr; + let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in + let mis = mismatch tr in + match tr with + | [] | _ :: [] -> assert false + | t1 :: t2 :: tr -> + try + let tr = filter_trace (mis = None) tr in + let t1, _t1' = may_prepare_expansion (tr = []) t1 + and t2, _t2' = may_prepare_expansion (tr = []) t2 in + let tr = List.map prepare_expansion tr in + fprintf ppf + "@[\ + %a%t\ + @]" + (trace2 prefix false "in the implementation, but according to the interface it should be") tr + (explanation unif mis); + if env <> Env.empty + then begin + warn_on_missing_def env ppf t1; + warn_on_missing_def env ppf t2 + end; + with exn -> + raise exn + let report_unification_error ppf env ?(unif=true) tr txt1 txt2 = wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) ;; +let report_unification_error2 prefix ppf env ?(unif=true) + tr (txt1: (formatter -> unit)) (txt2: (formatter -> unit)) = + wrap_printing_env env (fun () -> unification_error2 prefix env unif tr txt1 ppf txt2) +;; + let super_type_expansion ~tag t ppf t' = let tag = Format.String_tag tag in diff --git a/jscomp/ml/printtyp.mli b/jscomp/ml/printtyp.mli index 061aab30fe..f478c0535e 100644 --- a/jscomp/ml/printtyp.mli +++ b/jscomp/ml/printtyp.mli @@ -73,6 +73,11 @@ val report_unification_error: (formatter -> unit) -> (formatter -> unit) -> unit +val report_unification_error2: + (formatter -> unit) -> formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> + (formatter -> unit) -> (formatter -> unit) -> + unit + val super_report_unification_error: ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) ->