MPR#7937: avoid Unify exception when looking for type declaration

Changes

@@ -38,6 +38,12 @@ Working version
   unbound Unix socket. Add support for receiving abstract (Linux) socket paths.
   (Tim Cuthbertson, review by Sébastien Hinderer and Jérémie Dimino)
 
+### Bug fixes:
+
+- MPR#7937, GPR#2287: fix uncaught Unify exception when looking for type
+  declaration
+  (Florian Angeletti, review by Jacques Garrigue)
+
 OCaml 4.08.0
 ------------
 

testsuite/tests/typing-misc/ocamltests

@@ -14,6 +14,7 @@ pr6939-no-flat-float-array.ml
 pr7103.ml
 pr7228.ml
 pr7668_bad.ml
+pr7937.ml
 printing.ml
 records.ml
 scope_escape.ml

testsuite/tests/typing-misc/pr7937.ml

@@ -0,0 +1,84 @@
+(* TEST
+   * expect
+*)
+
+type 'a r = [< `X of int & 'a ] as 'a
+
+let f: 'a. 'a r -> 'a r = fun x -> true;;
+[%%expect {|
+type 'a r = 'a constraint 'a = [< `X of int & 'a ]
+Line 3, characters 35-39:
+3 | let f: 'a. 'a r -> 'a r = fun x -> true;;
+                                       ^^^^
+Error: This expression has type bool but an expression was expected of type
+         ([< `X of int & 'a ] as 'a) r
+       Types for tag `X are incompatible
+|}, Principal{|
+type 'a r = 'a constraint 'a = [< `X of int & 'a ]
+Line 3, characters 30-31:
+3 | let f: 'a. 'a r -> 'a r = fun x -> true;;
+                                  ^
+Error: This pattern matches values of type
+         ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r
+       but a pattern was expected which matches values of type
+         ([< `X of int & 'f ] as 'f) r
+       Types for tag `X are incompatible
+|}]
+
+let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };;
+[%%expect {|
+Line 1, characters 35-51:
+1 | let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };;
+                                       ^^^^^^^^^^^^^^^^
+Error: This expression has type int ref
+       but an expression was expected of type ([< `X of int & 'a ] as 'a) r
+       Types for tag `X are incompatible
+|}, Principal{|
+Line 1, characters 30-31:
+1 | let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };;
+                                  ^
+Error: This pattern matches values of type
+         ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r
+       but a pattern was expected which matches values of type
+         ([< `X of int & 'f ] as 'f) r
+       Types for tag `X are incompatible
+|}]
+
+let h: 'a. 'a r -> _ = function true | false -> ();;
+[%%expect {|
+Line 1, characters 32-36:
+1 | let h: 'a. 'a r -> _ = function true | false -> ();;
+                                    ^^^^
+Error: This pattern matches values of type bool
+       but a pattern was expected which matches values of type
+         ([< `X of int & 'a ] as 'a) r
+       Types for tag `X are incompatible
+|}, Principal{|
+Line 1, characters 32-36:
+1 | let h: 'a. 'a r -> _ = function true | false -> ();;
+                                    ^^^^
+Error: This pattern matches values of type bool
+       but a pattern was expected which matches values of type
+         ([< `X of 'b & 'a & 'c ] as 'a) r
+       Types for tag `X are incompatible
+|}]
+
+
+let i: 'a. 'a r -> _ = function { contents = 0 } -> ();;
+[%%expect {|
+Line 1, characters 32-48:
+1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();;
+                                    ^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type int ref
+       but a pattern was expected which matches values of type
+         ([< `X of int & 'a ] as 'a) r
+       Types for tag `X are incompatible
+|}, Principal{|
+Line 1, characters 32-48:
+1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();;
+                                    ^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type int ref
+       but a pattern was expected which matches values of type
+         ([< `X of 'b & 'a & 'c ] as 'a) r
+       Types for tag `X are incompatible
+|}]

typing/ctype.ml

@@ -1584,7 +1584,10 @@ let expand_head env ty =
 let _ = forward_try_expand_once := try_expand_safe
 
 
-(* Expand until we find a non-abstract type declaration *)
+(* Expand until we find a non-abstract type declaration,
+   use try_expand_safe to avoid raising "Unify _" when
+   called on recursive types
+ *)
 
 let rec extract_concrete_typedecl env ty =
   let ty = repr ty in
@@ -1593,7 +1596,7 @@ let rec extract_concrete_typedecl env ty =
       let decl = Env.find_type p env in
       if decl.type_kind <> Type_abstract then (p, p, decl) else
       let ty =
-        try try_expand_once env ty with Cannot_expand -> raise Not_found
+        try try_expand_safe env ty with Cannot_expand -> raise Not_found
       in
       let (_, p', decl) = extract_concrete_typedecl env ty in
         (p, p', decl)