diff --git a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml index 2f87d49587..920c11c743 100644 --- a/testsuite/tests/typing-layouts-unboxed-records/recursive.ml +++ b/testsuite/tests/typing-layouts-unboxed-records/recursive.ml @@ -78,7 +78,8 @@ Line 1, characters 0-31: 1 | type a_bad = #{ b_bad : b_bad } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The definition of "a_bad" is recursive without boxing: - "a_bad" contains "a_bad" + "a_bad" contains "b_bad", + "b_bad" contains "a_bad" |}] type bad : any = #{ bad : bad } @@ -165,9 +166,11 @@ Line 1, characters 0-21: ^^^^^^^^^^^^^^^^^^^^^ Error: The definition of "bad" is recursive without boxing: "bad" = "#(s * s)", - "#(s * s)" contains "u", + "#(s * s)" contains "s", + "s" contains "u", "u" = "#(int * bad record_id2)", - "#(int * bad record_id2)" contains "bad" + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" |}] type bad = #( s * s ) @@ -180,9 +183,11 @@ Line 1, characters 0-21: ^^^^^^^^^^^^^^^^^^^^^ Error: The definition of "bad" is recursive without boxing: "bad" = "#(s * s)", - "#(s * s)" contains "u", + "#(s * s)" contains "s", + "s" contains "u", "u" = "#(int * bad record_id2)", - "#(int * bad record_id2)" contains "bad" + "#(int * bad record_id2)" contains "bad record_id2", + "bad record_id2" contains "bad" |}] (* We also check recursive types via modules *) @@ -211,7 +216,8 @@ Lines 1-7, characters 0-3: 7 | end Error: The definition of "Bad_rec1.t" is recursive without boxing: "Bad_rec1.t" = "#(Bad_rec1.s * Bad_rec1.s)", - "#(Bad_rec1.s * Bad_rec1.s)" contains "Bad_rec2.u", + "#(Bad_rec1.s * Bad_rec1.s)" contains "Bad_rec1.s", + "Bad_rec1.s" contains "Bad_rec2.u", "Bad_rec2.u" = "Bad_rec1.t Bad_rec2.id", "Bad_rec1.t Bad_rec2.id" = "Bad_rec1.t", "Bad_rec1.t" = "#(Bad_rec1.s * Bad_rec1.s)", diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0b81155509..d74e05f060 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -3572,8 +3572,10 @@ module Reaching_path = struct (* Simplify a reaching path before showing it in error messages. *) let simplify path = + let is_tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false in let rec simplify : t -> t = function - | Contains (ty1, _ty2) :: Contains (_ty2', ty3) :: rest -> + | Contains (ty1, _ty2) :: Contains (ty2', ty3) :: rest + when not (is_tconstr ty2') -> (* If t1 contains t2 and t2 contains t3, then t1 contains t3 and we don't need to show t2. *) simplify (Contains (ty1, ty3) :: rest)