diff options
| -rw-r--r-- | Changes | 1 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/pr6241.ml | 16 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/pr6241.ml.principal.reference | 16 | ||||
| -rw-r--r-- | testsuite/tests/typing-gadts/pr6241.ml.reference | 16 | ||||
| -rw-r--r-- | typing/ctype.ml | 12 |
5 files changed, 56 insertions, 5 deletions
@@ -65,6 +65,7 @@ Bug fixes: - PR#6216: inlining of GADT matches generates invalid assembly - PR#6235: Issue with type information flowing through a variant pattern - PR#6240: Fail to expand module type abbreviation during substyping +- PR#6241: Assumed inequality between paths involving functor arguments OCaml 4.01.0: ------------- diff --git a/testsuite/tests/typing-gadts/pr6241.ml b/testsuite/tests/typing-gadts/pr6241.ml new file mode 100644 index 000000000..4034e4f89 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6241.ml @@ -0,0 +1,16 @@ +type (_, _) t = + A : ('a, 'a) t +| B : string -> ('a, 'b) t +;; + +module M (A : sig module type T end) (B : sig module type T end) = +struct + let f : ((module A.T), (module B.T)) t -> string = function + | B s -> s +end;; + +module A = struct module type T = sig end end;; + +module N = M(A)(A);; + +let x = N.f A;; diff --git a/testsuite/tests/typing-gadts/pr6241.ml.principal.reference b/testsuite/tests/typing-gadts/pr6241.ml.principal.reference new file mode 100644 index 000000000..65ea143c8 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6241.ml.principal.reference @@ -0,0 +1,16 @@ + +# type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t +# Characters 127-149: + ....................................................function + | B s -> s +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +A +module M : + functor (A : sig module type T end) -> + functor (B : sig module type T end) -> + sig val f : ((module A.T), (module B.T)) t -> string end +# module A : sig module type T = sig end end +# module N : sig val f : ((module A.T), (module A.T)) t -> string end +# Exception: Match_failure ("//toplevel//", 7, 52). +# diff --git a/testsuite/tests/typing-gadts/pr6241.ml.reference b/testsuite/tests/typing-gadts/pr6241.ml.reference new file mode 100644 index 000000000..65ea143c8 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6241.ml.reference @@ -0,0 +1,16 @@ + +# type (_, _) t = A : ('a, 'a) t | B : string -> ('a, 'b) t +# Characters 127-149: + ....................................................function + | B s -> s +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +A +module M : + functor (A : sig module type T end) -> + functor (B : sig module type T end) -> + sig val f : ((module A.T), (module B.T)) t -> string end +# module A : sig module type T = sig end end +# module N : sig val f : ((module A.T), (module A.T)) t -> string end +# Exception: Match_failure ("//toplevel//", 7, 52). +# diff --git a/typing/ctype.ml b/typing/ctype.ml index dc8f94cc2..cc56c8b3f 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1991,8 +1991,7 @@ let rec mcomp type_pairs env t1 t2 = | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> let decl = Env.find_type p env in if non_aliasable p decl then raise (Unify []) - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) - when Path.same p1 p2 && n1 = n2 -> + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> mcomp_list type_pairs env tl1 tl2 | (Tvariant row1, Tvariant row2) -> mcomp_row type_pairs env row1 row2 @@ -2398,9 +2397,12 @@ and unify3 env t1 t1' t2 t2' = unify env t1 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 Path.same p1 p2 && n1 = n2 -> - unify_list env tl1 tl2 + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> + if Path.same 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 + end | (_, _) -> raise (Unify []) end; |