diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index b031c119319..c988d46eaec 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5643,11 +5643,17 @@ 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) -> + 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 withExpr -> + BindOriginalRecdExpr withExpr (fun withExpr -> SynExpr.AnonRecd (isStruct, withExpr, unsortedFieldExprs, mWholeExpr, trivia)) + |> TcExpr cenv overallTy env tpenv | SynExpr.ArrayOrList (isArray, args, m) -> TcNonControlFlowExpr env <| fun env -> @@ -5673,8 +5679,14 @@ 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) + match withExprOpt with + | None + | Some(SynExpr.Ident _, _) -> + TcNonControlFlowExpr env <| fun env -> + TcExprRecord cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, mWholeExpr) + | Some withExpr -> + BindOriginalRecdExpr withExpr (fun withExpr -> SynExpr.Record (inherits, withExpr, synRecdFields, mWholeExpr)) + |> TcExpr cenv overallTy env tpenv | SynExpr.While (spWhile, synGuardExpr, synBodyExpr, m) -> TcExprWhileLoop cenv overallTy env tpenv (spWhile, synGuardExpr, synBodyExpr, m) diff --git a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs index a1d36d63593..8825b05a567 100644 --- a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs +++ b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs @@ -11,6 +11,9 @@ open FSharp.Compiler.SyntaxTreeOps open FSharp.Compiler.Text.Position open FSharp.Compiler.Text.Range open FSharp.Compiler.TypedTree +open FSharp.Compiler.Xml +open FSharp.Compiler.SyntaxTrivia +open TypedTreeOps /// Merges updates to nested record fields on the same level in record copy-and-update. /// @@ -146,3 +149,29 @@ let TransformAstForNestedUpdates (cenv: TcFileState) (env: TcEnv) overallTy (lid (accessIds, outerFieldId), Some(synExprRecd (recdExprCopyInfo (fields |> List.map fst) withExpr) outerFieldId rest exprBeingAssigned) + +/// When the original expression in copy-and-update is more complex than `{ x with ... }`, like `{ f () with ... }`, +/// we bind it first, so that it's not evaluated multiple times during a nested update +let BindOriginalRecdExpr (withExpr: SynExpr * BlockSeparator) mkRecdExpr = + let originalExpr, blockSep = withExpr + let mOrigExprSynth = originalExpr.Range.MakeSynthetic() + let id = mkSynId mOrigExprSynth "bind@" + let withExpr = SynExpr.Ident id, blockSep + + let binding = + mkSynBinding + (PreXmlDoc.Empty, mkSynPatVar None id) + (None, + false, + false, + mOrigExprSynth, + DebugPointAtBinding.NoneAtSticky, + None, + originalExpr, + mOrigExprSynth, + [], + [], + None, + SynBindingTrivia.Zero) + + SynExpr.LetOrUse(false, false, [ binding ], mkRecdExpr (Some withExpr), mOrigExprSynth, SynExprLetOrUseTrivia.Zero) diff --git a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi index f239c824361..4e4f40d7504 100644 --- a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi +++ b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi @@ -3,7 +3,6 @@ module internal FSharp.Compiler.CheckRecordSyntaxHelpers open FSharp.Compiler.CheckBasics -open FSharp.Compiler.NameResolution open FSharp.Compiler.Syntax open FSharp.Compiler.Text open FSharp.Compiler.TypedTree @@ -19,3 +18,6 @@ val TransformAstForNestedUpdates<'a> : exprBeingAssigned: SynExpr -> withExpr: SynExpr * (range * 'a) -> (Ident list * Ident) * SynExpr option + +val BindOriginalRecdExpr: + withExpr: SynExpr * BlockSeparator -> mkRecdExpr: ((SynExpr * BlockSeparator) option -> SynExpr) -> SynExpr diff --git a/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs index fbbf7f84be6..118fb0fb81f 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs +++ b/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'.") - ] \ No newline at end of file + ] + +[] +let ``Nested copy-and-update works when the starting expression is not a simple identifier``() = + FSharp """ +module CopyAndUpdateTests + +type Record1 = { Foo: int; Bar: int; } + +[] +module Module = + type Record2 = { Foo: Record1; G: string } + let item: Record2 = Unchecked.defaultof + +ignore { Module.item with Foo.Foo = 3 } + """ + |> withLangVersion80 + |> typecheck + |> shouldSucceed + +[] +let ``Nested, anonymous copy-and-update works when the starting expression is not a simple identifier``() = + FSharp """ +module CopyAndUpdateTests + +type Record1 = { Foo: int; Bar: int; } + +[] +module Module = + let item = {| Foo = Unchecked.defaultof |} + +ignore {| Module.item with Foo.Foo = 3 |} + """ + |> withLangVersion80 + |> typecheck + |> shouldSucceed + +[] +let ``Nested copy-and-update evaluates the original 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" \ No newline at end of file