Fix nested copy-and-update with complex original expressions

src/Compiler/Checking/CheckExpressions.fs

@@ -5639,11 +5639,27 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE
         TcNonControlFlowExpr env <| fun env ->
         TcExprTuple cenv overallTy env tpenv (isExplicitStruct, args, m)
 
-    | SynExpr.AnonRecd (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr, _) ->
-        TcNonControlFlowExpr env <| fun env ->
-        TcPossiblyPropagatingExprLeafThenConvert (fun ty -> isAnonRecdTy g ty || isTyparTy g ty) cenv overallTy env mWholeExpr (fun overallTy ->
-            TcAnonRecdExpr cenv overallTy env tpenv (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr)
-        )
+    | SynExpr.AnonRecd (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr, trivia) ->
+        // When the original expression in copy-and-update is more complex than `{| x with ... |}`, like `{| f () with ... |}`,
+        // bind it first, so that it's not evaluated multiple times during a nested update
+        match withExprOpt with
+        | None
+        | Some(SynExpr.Ident _, _) ->
+            TcNonControlFlowExpr env <| fun env ->
+            TcPossiblyPropagatingExprLeafThenConvert (fun ty -> isAnonRecdTy g ty || isTyparTy g ty) cenv overallTy env mWholeExpr (fun overallTy ->
+                TcAnonRecdExpr cenv overallTy env tpenv (isStruct, withExprOpt, unsortedFieldExprs, mWholeExpr)
+            )
+        | Some(expr, blockSep) ->
+            let mOrigExprSynth = expr.Range.MakeSynthetic()
+            let id = mkSynId mOrigExprSynth "bind@"
+            let binding = mkSynBinding (PreXmlDoc.Empty, mkSynPatVar None id) (None, false, false, mOrigExprSynth, DebugPointAtBinding.NoneAtSticky, None, expr, mOrigExprSynth, [], [], None, SynBindingTrivia.Zero)
+
+            let withExpr = SynExpr.Ident id, blockSep
+
+            let body = SynExpr.AnonRecd (isStruct, Some withExpr, unsortedFieldExprs, mWholeExpr, trivia)
+            let expr = SynExpr.LetOrUse (false, false, [ binding ], body, mOrigExprSynth, SynExprLetOrUseTrivia.Zero)
+
+            TcExpr cenv overallTy env tpenv expr
 
     | SynExpr.ArrayOrList (isArray, args, m) ->
         TcNonControlFlowExpr env <| fun env ->
@@ -5669,8 +5685,24 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE
         TcExprObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, mNewExpr, m)
 
     | SynExpr.Record (inherits, withExprOpt, synRecdFields, mWholeExpr) ->
-        TcNonControlFlowExpr env <| fun env ->
-        TcExprRecord cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr)
+        // When the original expression in copy-and-update is more complex than `{ x with ... }`, like `{ f () with ... }`,
+        // bind it first, so that it's not evaluated multiple times during a nested update
+        match withExprOpt with
+        | None
+        | Some(SynExpr.Ident _, _) ->
+            TcNonControlFlowExpr env <| fun env ->
+            TcExprRecord cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr)
+        | Some(expr, blockSep) ->
+            let mOrigExprSynth = expr.Range.MakeSynthetic()
+            let id = mkSynId mOrigExprSynth "bind@"
+            let binding = mkSynBinding (PreXmlDoc.Empty, mkSynPatVar None id) (None, false, false, mOrigExprSynth, DebugPointAtBinding.NoneAtSticky, None, expr, mOrigExprSynth, [], [], None, SynBindingTrivia.Zero)
+
+            let withExpr = SynExpr.Ident id, blockSep
+
+            let body = SynExpr.Record (inherits, Some withExpr, synRecdFields, mWholeExpr)
+            let expr = SynExpr.LetOrUse (false, false, [ binding ], body, mOrigExprSynth, SynExprLetOrUseTrivia.Zero)
+
+            TcExpr cenv overallTy env tpenv expr
 
     | SynExpr.While (spWhile, synGuardExpr, synBodyExpr, m) ->
         TcExprWhileLoop cenv overallTy env tpenv (spWhile, synGuardExpr, synBodyExpr, m)

tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs

@@ -423,4 +423,62 @@ let t7 (x: {| a: int; b: NestdRecTy |}) = {| x with c.D = "a" |}
         (Error 1129, Line 12, Col 55, Line 12, Col 56, "The record type 'NestdRecTy' does not contain a label 'C'.")
         (Error 1129, Line 13, Col 57, Line 13, Col 58, "The record type '{| a: int |}' does not contain a label 'b'.")
         (Error 1129, Line 14, Col 53, Line 14, Col 54, "The record type '{| a: int; b: NestdRecTy |}' does not contain a label 'c'.")
-    ]
+    ]
+
+[<Fact>]
+let ``Nested copy-and-update works when the starting expression is not a simple value``() =
+    FSharp """
+module CopyAndUpdateTests
+
+type Record1 = { Foo: int; Bar: int; }
+
+[<AutoOpen>]
+module Module =
+    type Record2 = { Foo: Record1; G: string }
+    let item: Record2 = Unchecked.defaultof<Record2>
+
+ignore { Module.item with Foo.Foo = 3 }
+    """
+    |> withLangVersion80
+    |> typecheck
+    |> shouldSucceed
+
+[<Fact>]
+let ``Nested, anonymous copy-and-update works when the starting expression is not a simple value``() =
+    FSharp """
+module CopyAndUpdateTests
+
+type Record1 = { Foo: int; Bar: int; }
+
+[<AutoOpen>]
+module Module =
+    let item = {| Foo = Unchecked.defaultof<Record1> |}
+
+ignore {| Module.item with Foo.Foo = 3 |}
+    """
+    |> withLangVersion80
+    |> typecheck
+    |> shouldSucceed
+
+[<Fact>]
+let ``Nested copy-and-update evalues the starting expression once``() =
+    FSharp """
+module CopyAndUpdateTests
+
+type Record1 = { Foo: int; Bar: int; Baz: string }
+type Record2 = { Foo: Record1; A: int; B: int }
+
+let f () =
+    printf "once"
+    { A = 1; B = 2; Foo = { Foo = 99; Bar = 98; Baz = "a" } }
+
+let actual = { f () with Foo.Foo = 3; Foo.Baz = "b"; A = -1 }
+
+let expected = { A = -1; B = 2; Foo = { Foo = 3; Bar = 98; Baz = "b" } }
+
+if actual <> expected then
+    failwith "actual does not equal expected"
+    """
+    |> withLangVersion80
+    |> compileExeAndRun
+    |> verifyOutput "once"