Fix #8747: incorrect principality warning on functional updates of records (#9709)

Changes

@@ -229,6 +229,9 @@ Working version
 
 ### Bug fixes:
 
+- #8747, #9709: incorrect principality warning on functional updates of records
+  (Jacques Garrigue, report and review by Thomas Refis)
+
 - #9469: Better backtraces for lazy values
   (Leo White, review by Nicolás Ojeda Bär)
 

testsuite/tests/typing-warnings/records.ml

@@ -670,3 +670,59 @@ Line 5, characters 12-15:
 Error: The field M.x belongs to the record type M.t
        but a field was expected belonging to the record type u
 |}]
+
+(* PR#8747 *)
+module M = struct type t = { x : int; y: char } end
+let f (x : M.t) = { x with y = 'a' }
+let g (x : M.t) = { x with y = 'a' } :: []
+let h (x : M.t) = { x with y = 'a' } :: { x with y = 'b' } :: [];;
+[%%expect{|
+module M : sig type t = { x : int; y : char; } end
+Line 2, characters 27-28:
+2 | let f (x : M.t) = { x with y = 'a' }
+                               ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Line 2, characters 18-36:
+2 | let f (x : M.t) = { x with y = 'a' }
+                      ^^^^^^^^^^^^^^^^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: y.
+They will not be selected if the type becomes unknown.
+val f : M.t -> M.t = <fun>
+Line 3, characters 27-28:
+3 | let g (x : M.t) = { x with y = 'a' } :: []
+                               ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Line 3, characters 18-36:
+3 | let g (x : M.t) = { x with y = 'a' } :: []
+                      ^^^^^^^^^^^^^^^^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: y.
+They will not be selected if the type becomes unknown.
+val g : M.t -> M.t list = <fun>
+Line 4, characters 27-28:
+4 | let h (x : M.t) = { x with y = 'a' } :: { x with y = 'b' } :: [];;
+                               ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Line 4, characters 18-36:
+4 | let h (x : M.t) = { x with y = 'a' } :: { x with y = 'b' } :: [];;
+                      ^^^^^^^^^^^^^^^^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: y.
+They will not be selected if the type becomes unknown.
+Line 4, characters 49-50:
+4 | let h (x : M.t) = { x with y = 'a' } :: { x with y = 'b' } :: [];;
+                                                     ^
+Warning 42: this use of y relies on type-directed disambiguation,
+it will not compile with OCaml 4.00 or earlier.
+Line 4, characters 40-58:
+4 | let h (x : M.t) = { x with y = 'a' } :: { x with y = 'b' } :: [];;
+                                            ^^^^^^^^^^^^^^^^^^
+Warning 40: this record of type M.t contains fields that are
+not visible in the current scope: y.
+They will not be selected if the type becomes unknown.
+val h : M.t -> M.t list = <fun>
+|}]

typing/typecore.ml

@@ -2836,23 +2836,26 @@ and type_expect_
             Some (p0, p, principal)
           with Not_found -> None
         in
-        match get_path ty_expected with
-          None ->
+        let opath = get_path ty_expected in
+        match opath with
+          None | Some (_, _, false) ->
+            let ty = if opath = None then newvar () else ty_expected in
             begin match opt_exp with
-              None -> newvar (), None
+              None -> ty, opath
             | Some exp ->
                 match get_path exp.exp_type with
-                  None -> newvar (), None
-                | Some (_, p', _) as op ->
+                  None ->
+                    ty, opath
+                | Some (_, p', _) as opath ->
                     let decl = Env.find_type p' env in
                     begin_def ();
                     let ty =
                       newconstr p' (instance_list decl.type_params) in
                     end_def ();
                     generalize_structure ty;
-                    ty, op
+                    ty, opath
             end
-        | op -> ty_expected, op
+        | _ -> ty_expected, opath
       in
       let closed = (opt_sexp = None) in
       let lbl_exp_list =