flambda-backend: Typedtree module unpacks: Incorporate upstream feedback (#1288)

* Incorporate garrigue's comment

It's closer to the old impl to check let-defs for scope escape rather
than only let-bound vars. We might as well continue to do that.

* Respond to more of garrigue's comments

* Remove global state for typechecking patterns (#1281)

* Remove global state for typechecking patterns

* These comments can go

* Two copies of `type_pat_state` when checking or-patterns

* Fix bug where `pattern_force` was dropped in or-patterns

* Respond to review

* remove the (we believe) unneeded call to generalize_structure

Author: ncik-roberts

testsuite/tests/typing-fstclassmod/scope_escape.ml

@@ -40,11 +40,14 @@ and (module A : S) =
 in
 ();;
 [%%expect{|
-Line 1, characters 8-9:
-1 | let rec k =
-            ^
-Error: This pattern matches values of type (module S with type t = A.t)
-       but a pattern was expected which matches values of type 'a
+Lines 2-6, characters 2-22:
+2 | ..let (module K : S with type t = A.t) = k in
+3 |   (module struct
+4 |     type t = K.t
+5 |   end : S
+6 |     with type t = K.t)
+Error: This expression has type (module S with type t = A.t)
+       but an expression was expected of type 'a
        The type constructor A.t would escape its scope
 |}];;
 

testsuite/tests/typing-objects/Tests.ml

@@ -779,6 +779,14 @@ Error: This expression has type 'a t but an expression was expected of type
          'a
        The type variable 'a occurs inside 'a t
 |}];;
+fun ((x : 'a) | (x : 'a t)) -> ();;
+[%%expect{|
+Line 1, characters 10-12:
+1 | fun ((x : 'a) | (x : 'a t)) -> ();;
+              ^^
+Error: This type 'a t should be an instance of type 'a
+       The type variable 'a occurs inside 'a t
+|}];;
 type 'a t = < x : 'a >;;
 [%%expect{|
 type 'a t = < x : 'a >
@@ -795,6 +803,14 @@ Line 1, characters 18-26:
 Warning 10 [non-unit-statement]: this expression should have type unit.
 - : ('a t as 'a) t -> unit = <fun>
 |}];;
+fun ((x : 'a) | (x : 'a t)) -> ();;
+[%%expect{|
+Line 1, characters 17-18:
+1 | fun ((x : 'a) | (x : 'a t)) -> ();;
+                     ^
+Warning 12 [redundant-subpat]: this sub-pattern is unused.
+- : ('a t as 'a) -> unit = <fun>
+|}];;
 
 class ['a] c () = object
   constraint 'a = < .. > -> unit

typing/typeclass.ml

@@ -1219,7 +1219,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
       in
       let partial =
         let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
-        Typecore.check_partial Modules_rejected val_env pat.pat_type pat.pat_loc
+        Typecore.check_partial val_env pat.pat_type pat.pat_loc
           [{c_lhs = pat; c_guard = None; c_rhs = dummy}]
       in
       let val_env' = Env.add_lock Alloc_mode.global val_env' in