#6262: equality of first-class modules take module type aliases into account. Fix interaction with module inclusion.

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

3 files changed, 33 insertions, 4 deletions

diff --git a/Changes b/Changes
index d137c73571..4867b3b7f2 100644
--- a/Changes
+++ b/Changes
@@ -41,6 +41,7 @@ Bug fixes:
 - PR#6109: Typos in ocamlbuild error messages
 - PR#6116: more efficient implementation of Digest.to_hex (patch by ygrek)
 - PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case)
+- PR#6262: equality of first-class modules take module aliases into account
 
 Standard library:
 - PR#4986: add List.sort_uniq and Set.of_list
diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml
index 268d35d492..82af377bec 100644
--- a/testsuite/tests/typing-fstclassmod/fstclassmod.ml
+++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml
@@ -139,3 +139,18 @@ end
 let () =
   print_endline (Print.to_string int 10);
   print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456)))
+
+
+(* #6262: first-class modules and module type aliases *)
+
+module type S1 = sig end
+module type S2 = S1
+
+let f (x : (module S1)) : (module S2) = x
+
+module X = struct
+  module type S
+end
+module Y = struct include X end
+
+let f (x : (module X.S)) : (module Y.S) = x
diff --git a/typing/ctype.ml b/typing/ctype.ml
index cc56c8b3f7..c00228ffe0 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -2169,6 +2169,19 @@ let order_type_pair t1 t2 =
 let add_type_equality t1 t2 =
   TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
 
+let rec normalize_package_path env p =
+  let t =
+    try (Env.find_modtype p env).mtd_type
+    with Not_found -> None
+  in
+  match t with
+  | Some (Mty_ident p) -> normalize_package_path env p
+  | Some (Mty_signature _ | Mty_functor _) | None -> p
+
+let eq_package_path env p1 p2 =
+  Path.same p1 p2 ||
+  Path.same (normalize_package_path env p1) (normalize_package_path env p2)
+
 let unify_eq env t1 t2 =
   t1 == t2 ||
   match !umode with
@@ -2398,7 +2411,7 @@ and unify3 env t1 t1' t2 t2' =
       | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
           enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
       | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 ->
-          if Path.same p1 p2 then unify_list env tl1 tl2 else
+          if eq_package_path !env p1 p2 then unify_list env tl1 tl2 else
           if !umode = Expression then raise (Unify []) else begin
             List.iter (reify env) (tl1 @ tl2);
             if !generate_equations then List.iter2 (mcomp !env) tl1 tl2
@@ -2829,7 +2842,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
                 when Path.same p1 p2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
           | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
-            when Path.same p1 p2 && n1 = n2 ->
+            when eq_package_path env p1 p2 && n1 = n2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
@@ -3097,7 +3110,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
                 when Path.same p1 p2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
           | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
-            when Path.same p1 p2 && n1 = n2 ->
+            when eq_package_path env p1 p2 && n1 = n2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
@@ -3839,7 +3852,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
           (trace, t1, t2, !univar_pairs)::cstrs
         end
     | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2))
-      when Path.same p1 p2 && included nl2 nl1 ->
+      when eq_package_path env p1 p2 && included nl2 nl1 ->
         List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs))
           (extract_assoc nl2 nl1 tl1) tl2
         @ cstrs