From a0f9cf68c1b4869eba3a1de0d9b1c0059bb170d1 Mon Sep 17 00:00:00 2001
From: Florian Angeletti <florian.angeletti@inria.fr>
Date: Mon, 17 Oct 2022 14:59:56 +0200
Subject: [PATCH] Merge pull request #11622 from
 Octachron/fix_recursive_types_in_constructor_mismatch

Printtyp: avoid stack overflow when printing constructors or records with recursive types in inclusion error messages
(cherry picked from commit 74e6ee290b6782891eb14eccb97ed3bd9b4083e3)
---
 Changes                                       |  4 +
 .../tests/typing-modules/inclusion_errors.ml  | 93 +++++++++++++++++++
 typing/printtyp.ml                            |  5 +
 3 files changed, 102 insertions(+)

diff --git a/Changes b/Changes
index 31808d754a52..7e479180b637 100644
--- a/Changes
+++ b/Changes
@@ -506,6 +506,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)
 ----------------------------
 
diff --git a/testsuite/tests/typing-modules/inclusion_errors.ml b/testsuite/tests/typing-modules/inclusion_errors.ml
index 4e7ff09b77c3..e4333a08a1d8 100644
--- a/testsuite/tests/typing-modules/inclusion_errors.ml
+++ b/testsuite/tests/typing-modules/inclusion_errors.ml
@@ -1715,3 +1715,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
+|}]
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 7e87cd4734ef..88d67013c5bf 100644
--- a/typing/printtyp.ml
+++ b/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