more precise extension mismatch error messages

testsuite/tests/shadow_include/shadow_all.ml

@@ -100,11 +100,11 @@ end
 Line 4, characters 2-11:
     include S
     ^^^^^^^^^
-Error: Illegal shadowing of included type t/1155 by t/1172
+Error: Illegal shadowing of included type t/1143 by t/1160
        Line 2, characters 2-11:
-         Type t/1155 came from this include
+         Type t/1143 came from this include
        Line 3, characters 2-24:
-         The value ignore has no valid type if t/1155 is shadowed
+         The value ignore has no valid type if t/1143 is shadowed
 |}]
 
 module type Module = sig
@@ -140,11 +140,11 @@ end
 Line 4, characters 2-11:
     include S
     ^^^^^^^^^
-Error: Illegal shadowing of included module M/1247 by M/1264
+Error: Illegal shadowing of included module M/1231 by M/1248
        Line 2, characters 2-11:
-         Module M/1247 came from this include
+         Module M/1231 came from this include
        Line 3, characters 2-26:
-         The value ignore has no valid type if M/1247 is shadowed
+         The value ignore has no valid type if M/1231 is shadowed
 |}]
 
 
@@ -181,11 +181,11 @@ end
 Line 4, characters 2-11:
     include S
     ^^^^^^^^^
-Error: Illegal shadowing of included module type T/1336 by T/1354
+Error: Illegal shadowing of included module type T/1316 by T/1334
        Line 2, characters 2-11:
-         Module type T/1336 came from this include
+         Module type T/1316 came from this include
        Line 3, characters 2-39:
-         The module F has no valid type if T/1336 is shadowed
+         The module F has no valid type if T/1316 is shadowed
 |}]
 
 module type Extension = sig
@@ -198,11 +198,11 @@ end
 Line 4, characters 2-11:
     include S
     ^^^^^^^^^
-Error: Illegal shadowing of included type ext/1372 by ext/1389
+Error: Illegal shadowing of included type ext/1352 by ext/1369
        Line 2, characters 2-11:
-         Type ext/1372 came from this include
+         Type ext/1352 came from this include
        Line 3, characters 14-16:
-         The extension constructor C2 has no valid type if ext/1372 is shadowed
+         The extension constructor C2 has no valid type if ext/1352 is shadowed
 |}]
 
 module type Class = sig

testsuite/tests/typing-modules/Test.ml

@@ -137,10 +137,11 @@ Error: Signature mismatch:
          sig type t += E of int end
        is not included in
          sig type t += E end
-       Extension declarations do not match:
+       Extension declarations not match:
          type t += E of int
        is not included in
          type t += E
+       The arities for field E differ.
 |}];;
 
 module M : sig type t += E of char end = struct type t += E of int end;;
@@ -153,10 +154,11 @@ Error: Signature mismatch:
          sig type t += E of int end
        is not included in
          sig type t += E of char end
-       Extension declarations do not match:
+       Extension declarations not match:
          type t += E of int
        is not included in
          type t += E of char
+       The types for field E are not equal.
 |}];;
 
 module M : sig type t += C of int end = struct type t += E of int end;;
@@ -182,8 +184,9 @@ Error: Signature mismatch:
          sig type t += E of int end
        is not included in
          sig type t += E of { x : int; } end
-       Extension declarations do not match:
+       Extension declarations not match:
          type t += E of int
        is not included in
          type t += E of { x : int; }
+       The types for field E are not equal.
 |}];;

typing/includecore.ml

@@ -169,34 +169,32 @@ let report_type_mismatch0 first second decl ppf err =
          "uses unboxed representation"
   | Immediate -> pr "%s is not an immediate type" first
 
-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)
+let report_type_mismatch first second decl ppf err =
+  if err = Manifest then () else
+  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
   | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
-      if List.length arg1 <> List.length arg2 then [Field_arity cstr]
+      if List.length arg1 <> List.length arg2 then Some (Field_arity cstr)
       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 None else Some (Field_type cstr)
   | Types.Cstr_record l1, Types.Cstr_record l2 ->
       compare_records env ~loc params1 params2 0 l1 l2
-  | _ -> [Field_type cstr]
+  | _ -> Some (Field_type cstr)
 
 and compare_variants ~loc env params1 params2 n
     (cstrs1 : Types.constructor_declaration list)
     (cstrs2 : Types.constructor_declaration list) =
   match cstrs1, cstrs2 with
-    [], []           -> []
-  | [], c::_ -> [Field_missing (true, c.Types.cd_id)]
-  | c::_, [] -> [Field_missing (false, c.Types.cd_id)]
+    [], []           -> None
+  | [], c::_ -> Some (Field_missing (true, c.Types.cd_id))
+  | c::_, [] -> Some (Field_missing (false, c.Types.cd_id))
   | cd1::rem1, cd2::rem2 ->
       if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
-        [Field_names (n, cd1.cd_id, cd2.cd_id)]
+        Some (Field_names (n, cd1.cd_id, cd2.cd_id))
       else begin
         Builtin_attributes.check_deprecated_inclusion
           ~def:cd1.cd_loc
@@ -210,14 +208,14 @@ 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 Some (Field_type cd1.cd_id)
           | Some _, None | None, Some _ ->
-              [Field_type cd1.cd_id]
+              Some (Field_type cd1.cd_id)
           | _ ->
               compare_constructor_arguments ~loc env cd1.cd_id
                 params1 params2 cd1.cd_args cd2.cd_args
         in
-        if r <> [] then r
+        if r <> None then r
         else compare_variants ~loc env params1 params2 (n+1) rem1 rem2
       end
 
@@ -226,14 +224,14 @@ and compare_records ~loc env params1 params2 n
     (labels1 : Types.label_declaration list)
     (labels2 : Types.label_declaration list) =
   match labels1, labels2 with
-    [], []           -> []
-  | [], l::_ -> [Field_missing (true, l.Types.ld_id)]
-  | l::_, [] -> [Field_missing (false, l.Types.ld_id)]
+    [], []           -> None
+  | [], l::_ -> Some (Field_missing (true, l.Types.ld_id))
+  | l::_, [] -> Some (Field_missing (false, l.Types.ld_id))
   | ld1::rem1, ld2::rem2 ->
       if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
-      then [Field_names (n, ld1.ld_id, ld2.ld_id)]
+      then Some (Field_names (n, ld1.ld_id, ld2.ld_id))
       else if ld1.ld_mutable <> ld2.ld_mutable then
-        [Field_mutable ld1.ld_id]
+        Some (Field_mutable ld1.ld_id)
       else begin
         Builtin_attributes.check_deprecated_mutable_inclusion
           ~def:ld1.ld_loc
@@ -248,7 +246,7 @@ and compare_records ~loc env params1 params2 n
             (n+1)
             rem1 rem2
         else
-          [Field_type ld1.ld_id]
+          Some (Field_type ld1.ld_id)
       end
 
 let type_declarations ?(equality = false) ~loc env ~mark name decl1 id decl2 =
@@ -258,37 +256,37 @@ let type_declarations ?(equality = false) ~loc env ~mark name decl1 id decl2 =
     loc
     decl1.type_attributes decl2.type_attributes
     name;
-  if decl1.type_arity <> decl2.type_arity then [Arity] else
-  if not (private_flags decl1 decl2) then [Privacy] else
+  if decl1.type_arity <> decl2.type_arity then Some Arity else
+  if not (private_flags decl1 decl2) then Some Privacy else
   let err = match (decl1.type_manifest, decl2.type_manifest) with
       (_, None) ->
         if Ctype.equal env true decl1.type_params decl2.type_params
-        then [] else [Constraint]
+        then None else Some Constraint
     | (Some ty1, Some ty2) ->
         if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
             decl2.type_private
-        then [] else [Manifest]
+        then None else Some Manifest
     | (None, Some ty2) ->
         let ty1 =
           Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
         in
         if Ctype.equal env true decl1.type_params decl2.type_params then
-          if Ctype.equal env false [ty1] [ty2] then []
-          else [Manifest]
-        else [Constraint]
+          if Ctype.equal env false [ty1] [ty2] then None
+          else Some Manifest
+        else Some Constraint
   in
-  if err <> [] then err else
+  if err <> None then err else
   let err =
     match (decl2.type_kind, decl1.type_unboxed.unboxed,
            decl2.type_unboxed.unboxed) with
-    | Type_abstract, _, _ -> []
-    | _, true, false -> [Unboxed_representation false]
-    | _, false, true -> [Unboxed_representation true]
-    | _ -> []
+    | Type_abstract, _, _ -> None
+    | _, true, false -> Some (Unboxed_representation false)
+    | _, false, true -> Some (Unboxed_representation true)
+    | _ -> None
   in
-  if err <> [] then err else
+  if err <> None then err else
   let err = match (decl1.type_kind, decl2.type_kind) with
-      (_, Type_abstract) -> []
+      (_, Type_abstract) -> None
     | (Type_variant cstrs1, Type_variant cstrs2) ->
         if mark then begin
           let mark cstrs usage name decl =
@@ -312,26 +310,26 @@ let type_declarations ?(equality = false) ~loc env ~mark name decl1 id decl2 =
           compare_records ~loc env decl1.type_params
             decl2.type_params 1 labels1 labels2
         in
-        if err <> [] || rep1 = rep2 then err else
-        [Record_representation (rep2 = Record_float)]
-    | (Type_open, Type_open) -> []
-    | (_, _) -> [Kind]
+        if err <> None || rep1 = rep2 then err else
+        Some (Record_representation (rep2 = Record_float))
+    | (Type_open, Type_open) -> None
+    | (_, _) -> Some Kind
   in
-  if err <> [] then err else
+  if err <> None then err else
   let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
   (* If attempt to assign a non-immediate type (e.g. string) to a type that
    * must be immediate, then we error *)
   let err =
     if abstr &&
        not decl1.type_immediate &&
        decl2.type_immediate then
-      [Immediate]
-    else []
+      Some Immediate
+    else None
   in
-  if err <> [] then err else
+  if err <> None then err else
   let need_variance =
     abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
-  if not need_variance then [] else
+  if not need_variance then None else
   let abstr = abstr || decl2.type_private = Private in
   let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
   let constrained ty = not (Btype.(is_Tvar (repr ty))) in
@@ -346,7 +344,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name decl1 id decl2 =
         let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
         imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
       decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
-  then [] else [Variance]
+  then None else Some Variance
 
 (* Inclusion between extension constructors *)
 
@@ -364,21 +362,23 @@ let extension_constructors ~loc env ~mark id ext1 ext2 =
   let ty2 =
     Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
   in
-  if Ctype.equal env true
-       (ty1 :: ext1.ext_type_params)
-       (ty2 :: ext2.ext_type_params)
-  then
-    if compare_constructor_arguments ~loc env (Ident.create "")
+  if
+    not (Ctype.equal env true (ty1 :: ext1.ext_type_params)
+           (ty2 :: ext2.ext_type_params))
+  then Some (Field_type id)
+  else
+    let r =
+      compare_constructor_arguments ~loc env id
         ext1.ext_type_params ext2.ext_type_params
-        ext1.ext_args ext2.ext_args = [] then
-      if match ext1.ext_ret_type, ext2.ext_ret_type with
-          Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false
-        | Some _, None | None, Some _ -> false
-        | _ -> true
-      then
+        ext1.ext_args ext2.ext_args
+    in
+    if r <> None then r else
+    match ext1.ext_ret_type, ext2.ext_ret_type with
+      Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) ->
+        Some (Field_type id)
+    | Some _, None | None, Some _ ->
+        Some (Field_type id)
+    | _ ->
         match ext1.ext_private, ext2.ext_private with
-            Private, Public -> false
-          | _, _ -> true
-      else false
-    else false
-  else false
+          Private, Public -> Some Privacy
+        | _, _ -> None

typing/includecore.mli

@@ -44,15 +44,15 @@ val type_declarations:
   ?equality:bool ->
   loc:Location.t ->
   Env.t -> mark:bool -> string ->
-  type_declaration -> Ident.t -> type_declaration -> type_mismatch list
+  type_declaration -> Ident.t -> type_declaration -> type_mismatch option
 
 val extension_constructors:
   loc:Location.t -> Env.t -> mark:bool -> Ident.t ->
-  extension_constructor -> extension_constructor -> bool
+  extension_constructor -> extension_constructor -> type_mismatch option
 (*
 val class_types:
         Env.t -> class_type -> class_type -> bool
 *)
 
 val report_type_mismatch:
-    string -> string -> string -> Format.formatter -> type_mismatch list -> unit
+    string -> string -> string -> Format.formatter -> type_mismatch -> unit