Fix PR#5993

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13580 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 36 insertions, 8 deletions

diff --git a/Changes b/Changes
index 6c4d4acc8..438fb6677 100644
--- a/Changes
+++ b/Changes
@@ -80,6 +80,7 @@ Bug fixes:
 - PR#5930: ocamldep leaks temporary preprocessing files
 - PR#5934: integer shift by negative amount (in otherlibs/num)
 - PR#5920, PR#2957: linking failure for big bytecodes on 32bit architectures
+- PR#5981: Incompatibility check assumes abstracted types are injective
 
 Internals:
 - Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary
@@ -123,8 +124,8 @@ Bug fixes:
 - PR#5907: Undetected cycle during typecheck causes exceptions
 - PR#5911: Signature substitutions fail in submodules
 - PR#5948: GADT with polymorphic variants bug
-- PR#5981: Incompatibility check assumes abstracted types are injective
 - PR#5989: Assumed inequalities involving private rows
+- PR#5993: Variance of private type abbreviations not checked for modules
 
 OCaml 4.00.1:
 -------------
diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
index afc170545..697955005 100644
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -38,3 +38,9 @@ let id = let module M = struct end in fun x -> x;;
 (* PR#4511 *)
 
 let ko = let module M = struct end in fun _ -> ();;
+
+(* PR#5993 *)
+
+module M : sig type -'a t = private int end =
+  struct type +'a t = private int end
+;;
diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
index c4ad0a05b..d60095213 100644
--- a/testsuite/tests/typing-modules/Test.ml.principal.reference
+++ b/testsuite/tests/typing-modules/Test.ml.principal.reference
@@ -8,4 +8,17 @@ class type c = object method m : [ `A ] t end
 #   module M : sig val v : (#c as 'a) -> 'a end
 #       val id : 'a -> 'a = <fun>
 #       val ko : 'a -> unit = <fun>
+#           Characters 64-99:
+    struct type +'a t = private int end
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
 # 
diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
index c4ad0a05b..d60095213 100644
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ b/testsuite/tests/typing-modules/Test.ml.reference
@@ -8,4 +8,17 @@ class type c = object method m : [ `A ] t end
 #   module M : sig val v : (#c as 'a) -> 'a end
 #       val id : 'a -> 'a = <fun>
 #       val ko : 'a -> unit = <fun>
+#           Characters 64-99:
+    struct type +'a t = private int end
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Signature mismatch:
+       Modules do not match:
+         sig type +'a t = private int end
+       is not included in
+         sig type -'a t = private int end
+       Type declarations do not match:
+         type +'a t = private int
+       is not included in
+         type -'a t = private int
+       Their variances do not agree.
 # 
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 3a2d9df82..973e31265 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -244,13 +244,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
         else [Constraint]
   in
   if err <> [] then err else
-  if match decl2.type_kind with
-  | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private
-  | Type_abstract ->
-      match decl2.type_manifest with
-      | None -> true
-      | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty)
-  then
+  if decl2.type_private = Private
+  || decl2.type_kind = Type_abstract && decl2.type_manifest = None then
     if List.for_all2
         (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2)&&(not cn1 || cn2))
         decl1.type_variance decl2.type_variance