Merge pull request #11622 from Octachron/fix_recursive_types_in_const…

…ructor_mismatch

Printtyp: avoid stack overflow when printing constructors or records with recursive types in inclusion error messages

Changes

@@ -682,6 +682,10 @@ OCaml 5.0
 - #11587: Prevent integer comparison from being used on pointers
   (Vincent Laviron, review by Gabriel Scherer)
 
+- #11622: Prevent stack overflow when printing a constructor or record
+  mismatch error involving recursive types.
+  (Florian Angeletti, review by Gabriel Scherer)
+
 OCaml 4.14.0 (28 March 2022)
 ----------------------------
 

testsuite/tests/typing-modules/inclusion_errors.ml

@@ -1714,3 +1714,96 @@ Error: Signature mismatch:
          type t = < m : int >
        A private row type would be revealed.
 |}];;
+
+
+(** Unexpected recursive types *)
+module M: sig
+  type _ t = A : (<x:'a> as 'a) -> (<y:'b> as 'b) t
+end = struct
+  type _ t = A : (<x:'a * 'a> as 'a) -> (<y:'b> as 'b) t
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type _ t = A : (<x:'a * 'a> as 'a) -> (<y:'b> as 'b) t
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t
+         end
+       is not included in
+         sig type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t end
+       Type declarations do not match:
+         type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t
+       is not included in
+         type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t
+       Constructors do not match:
+         A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t
+       is not the same as:
+         A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t
+       The type < x : 'a * 'a > as 'a is not equal to the type
+         < x : 'b > as 'b
+       Types for method x are incompatible
+|}]
+module R: sig
+  type t = { a: (<x:'a> as 'a) }
+end = struct
+  type t = { a: (<x:'a * 'a> as 'a) }
+end
+[%%expect {|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = { a: (<x:'a * 'a> as 'a) }
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { a : < x : 'a * 'a > as 'a; } end
+       is not included in
+         sig type t = { a : < x : 'a > as 'a; } end
+       Type declarations do not match:
+         type t = { a : < x : 'a * 'a > as 'a; }
+       is not included in
+         type t = { a : < x : 'a > as 'a; }
+       Fields do not match:
+         a : < x : 'a * 'a > as 'a;
+       is not the same as:
+         a : < x : 'a > as 'a;
+       The type < x : 'a * 'a > as 'a is not equal to the type
+         < x : 'b > as 'b
+       Types for method x are incompatible
+|}]
+type _ ext = ..
+module Ext: sig
+  type _ ext += A : (<x:'a> as 'a) -> (<y:'b> as 'b) ext
+end = struct
+  type _ ext  += A : (<x:'a * 'a> as 'a) -> (<y:'b> as 'b) ext
+end
+[%%expect {|
+type _ ext = ..
+Lines 4-6, characters 6-3:
+4 | ......struct
+5 |   type _ ext  += A : (<x:'a * 'a> as 'a) -> (<y:'b> as 'b) ext
+6 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig
+           type _ ext +=
+               A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext
+         end
+       is not included in
+         sig
+           type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext
+         end
+       Extension declarations do not match:
+         type _ ext += A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext
+       is not included in
+         type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext
+       Constructors do not match:
+         A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext
+       is not the same as:
+         A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext
+       The type < x : 'a * 'a > as 'a is not equal to the type
+         < x : 'b > as 'b
+       Types for method x are incompatible
+|}]

typing/printtyp.ml

@@ -1466,10 +1466,13 @@ and tree_of_label l =
 
 let constructor ppf c =
   reset_except_context ();
+  prepare_type_constructor_arguments c.cd_args;
+  Option.iter prepare_type c.cd_res;
   !Oprint.out_constr ppf (tree_of_constructor c)
 
 let label ppf l =
   reset_except_context ();
+  prepare_type l.ld_type;
   !Oprint.out_label ppf (tree_of_label l)
 
 let tree_of_type_declaration id decl rs =
@@ -1537,6 +1540,8 @@ let extension_constructor id ppf ext =
 
 let extension_only_constructor id ppf ext =
   reset_except_context ();
+  prepare_type_constructor_arguments ext.ext_args;
+  Option.iter prepare_type ext.ext_ret_type;
   let name = Ident.name id in
   let args, ret =
     extension_constructor_args_and_ret_type_subtree