Fix PR#7135: only warn about ground coercions in -principal mode

Changes

@@ -443,6 +443,8 @@ Bug fixes:
 - PR#7096: ocamldoc uses an incorrect subscript/superscript style
 - PR#7115: shadowing in a branch of a GADT match breaks unused variable
   warning (Alain Frisch, report by Valentin Gatien-Baron)
+- PR#7135: only warn about ground coercions in -principal mode
+  (Jacques Garrigue, report by Jeremy Yallop)
 - GPR#205: Clear caml_backtrace_last_exn before registering as root
   (report and fix by Frederic Bour)
 - GPR#220: minor -dsource error on recursive modules

testsuite/tests/typing-warnings/coercions.ml

@@ -3,3 +3,20 @@
 fun b -> if b then format_of_string "x" else "y";;
 fun b -> if b then "x" else format_of_string "y";;
 fun b : (_,_,_) format -> if b then "x" else "y";;
+
+(* PR#7135 *)
+
+module PR7135 = struct
+  module M : sig type t = private int end =  struct type t = int end
+  include M
+
+  let lift2 (f : int -> int -> int) (x : t) (y : t) =
+    f (x :> int) (y :> int)
+end;;
+
+(* exemple of non-ground coercion *)
+
+module Test1 = struct
+  type t = private int
+  let f x = let y = if true then x else (x:t) in (y :> int)
+end;;

testsuite/tests/typing-warnings/coercions.ml.principal.reference

@@ -12,4 +12,15 @@ Error: This expression has type
            ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
        but an expression was expected of type string
 # - : bool -> ('a, 'b, 'a) format = <fun>
+#                   module PR7135 :
+  sig
+    module M : sig type t = private int end
+    type t = M.t
+    val lift2 : (int -> int -> int) -> t -> t -> int
+  end
+#             Characters 133-143:
+    let f x = let y = if true then x else (x:t) in (y :> int)
+                                                   ^^^^^^^^^^
+Warning 18: this ground coercion is not principal.
+module Test1 : sig type t = private int val f : t -> int end
 # 

testsuite/tests/typing-warnings/coercions.ml.reference

@@ -8,4 +8,11 @@ Error: This expression has type
            ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
        but an expression was expected of type string
 # - : bool -> ('a, 'b, 'a) format = <fun>
+#                   module PR7135 :
+  sig
+    module M : sig type t = private int end
+    type t = M.t
+    val lift2 : (int -> int -> int) -> t -> t -> int
+  end
+#             module Test1 : sig type t = private int val f : t -> int end
 # 

testsuite/typing

@@ -7,9 +7,11 @@ tests/basic-modules
 tests/basic-more
 tests/basic-multdef
 tests/basic-private
+tests/typing-extension-constructor
 tests/typing-extensions
 tests/typing-fstclassmod
 tests/typing-gadts
+tests/typing-immediate
 tests/typing-implicit_unpack
 tests/typing-labels
 tests/typing-misc
@@ -26,9 +28,12 @@ tests/typing-polyvariants-bugs-2
 tests/typing-private
 tests/typing-private-bugs
 tests/typing-recmod
+tests/typing-recordarg
 tests/typing-rectypes-bugs
 tests/typing-short-paths
 tests/typing-signatures
 tests/typing-sigsubst
 tests/typing-typeparam
+tests/typing-unboxed
 tests/typing-warnings
+tests/warnings

typing/typecore.ml

@@ -2411,8 +2411,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
           (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
       }
   | Pexp_coerce(sarg, sty, sty') ->
-      let separate = true (* always separate, 1% slowdown for lablgtk *)
-        (* !Clflags.principal || Env.has_local_constraints env *) in
+      (* Could be always true, only 1% slowdown for lablgtk *)
+      let separate = !Clflags.principal || Env.has_local_constraints env in
       let (arg, ty',cty,cty') =
         match sty with
         | None ->
@@ -2450,7 +2450,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                 else begin try
                   let force' = subtype env arg.exp_type ty' in
                   force (); force' ();
-                  if not gen then
+                  if not gen && !Clflags.principal then
                     Location.prerr_warning loc
                       (Warnings.Not_principal "this ground coercion");
                 with Subtype (tr1, tr2) ->