From a04d9cf7b8ccaaff2089db306d65eb00657ee770 Mon Sep 17 00:00:00 2001 From: kerams Date: Fri, 10 Nov 2023 18:20:24 +0100 Subject: [PATCH 1/3] Fix nested copy-and-update with complex original expressions --- src/Compiler/Checking/CheckExpressions.fs | 46 +++++++++++--- .../Language/CopyAndUpdateTests.fs | 60 ++++++++++++++++++- 2 files changed, 98 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 302a338ccdf..c1644e4d107 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/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) diff --git a/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs index fbbf7f84be6..a02018daf63 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 value``() = + 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 value``() = + 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 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" \ No newline at end of file From 111cf6e7c2c33faa95e2acc335e66119c4c0f2da Mon Sep 17 00:00:00 2001 From: kerams Date: Sat, 11 Nov 2023 10:53:11 +0100 Subject: [PATCH 2/3] Refactor --- src/Compiler/Checking/CheckExpressions.fs | 30 +++---------------- .../Checking/CheckRecordSyntaxHelpers.fs | 30 +++++++++++++++++++ .../Checking/CheckRecordSyntaxHelpers.fsi | 7 ++++- .../Language/CopyAndUpdateTests.fs | 6 ++-- 4 files changed, 43 insertions(+), 30 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index c1644e4d107..09ab7ea52f7 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5640,8 +5640,6 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE TcExprTuple cenv overallTy env tpenv (isExplicitStruct, args, m) | 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 _, _) -> @@ -5649,17 +5647,8 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE 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 + | 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 -> @@ -5685,24 +5674,13 @@ 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) -> - // 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 + | 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..e93ab7f2458 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,30 @@ 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 (tcExpr: SynExpr -> Expr * UnscopedTyparEnv) = + 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) + |> tcExpr diff --git a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi index f239c824361..37cfab77c14 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,9 @@ val TransformAstForNestedUpdates<'a> : exprBeingAssigned: SynExpr -> withExpr: SynExpr * (range * 'a) -> (Ident list * Ident) * SynExpr option + +val BindOriginalRecdExpr: + withExpr: SynExpr * BlockSeparator -> + mkRecdExpr: ((SynExpr * BlockSeparator) option -> SynExpr) -> + tcExpr: (SynExpr -> Expr * UnscopedTyparEnv) -> + Expr * UnscopedTyparEnv diff --git a/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs b/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs index a02018daf63..118fb0fb81f 100644 --- a/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Language/CopyAndUpdateTests.fs @@ -426,7 +426,7 @@ let t7 (x: {| a: int; b: NestdRecTy |}) = {| x with c.D = "a" |} ] [] -let ``Nested copy-and-update works when the starting expression is not a simple value``() = +let ``Nested copy-and-update works when the starting expression is not a simple identifier``() = FSharp """ module CopyAndUpdateTests @@ -444,7 +444,7 @@ ignore { Module.item with Foo.Foo = 3 } |> shouldSucceed [] -let ``Nested, anonymous copy-and-update works when the starting expression is not a simple value``() = +let ``Nested, anonymous copy-and-update works when the starting expression is not a simple identifier``() = FSharp """ module CopyAndUpdateTests @@ -461,7 +461,7 @@ ignore {| Module.item with Foo.Foo = 3 |} |> shouldSucceed [] -let ``Nested copy-and-update evalues the starting expression once``() = +let ``Nested copy-and-update evaluates the original expression once``() = FSharp """ module CopyAndUpdateTests From 1920f9f0dcffe062d83a9d6522729445cb7a1b21 Mon Sep 17 00:00:00 2001 From: kerams Date: Mon, 13 Nov 2023 10:59:33 +0100 Subject: [PATCH 3/3] Refactor --- src/Compiler/Checking/CheckExpressions.fs | 6 ++++-- src/Compiler/Checking/CheckRecordSyntaxHelpers.fs | 3 +-- src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi | 5 +---- 3 files changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 09ab7ea52f7..2470c4d024e 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5648,7 +5648,8 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE 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) + 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 -> @@ -5680,7 +5681,8 @@ and TcExprUndelayed (cenv: cenv) (overallTy: OverallTy) env tpenv (synExpr: SynE 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) + 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 e93ab7f2458..8825b05a567 100644 --- a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs +++ b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fs @@ -152,7 +152,7 @@ let TransformAstForNestedUpdates (cenv: TcFileState) (env: TcEnv) overallTy (lid /// 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 (tcExpr: SynExpr -> Expr * UnscopedTyparEnv) = +let BindOriginalRecdExpr (withExpr: SynExpr * BlockSeparator) mkRecdExpr = let originalExpr, blockSep = withExpr let mOrigExprSynth = originalExpr.Range.MakeSynthetic() let id = mkSynId mOrigExprSynth "bind@" @@ -175,4 +175,3 @@ let BindOriginalRecdExpr (withExpr: SynExpr * BlockSeparator) mkRecdExpr (tcExpr SynBindingTrivia.Zero) SynExpr.LetOrUse(false, false, [ binding ], mkRecdExpr (Some withExpr), mOrigExprSynth, SynExprLetOrUseTrivia.Zero) - |> tcExpr diff --git a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi index 37cfab77c14..4e4f40d7504 100644 --- a/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi +++ b/src/Compiler/Checking/CheckRecordSyntaxHelpers.fsi @@ -20,7 +20,4 @@ val TransformAstForNestedUpdates<'a> : (Ident list * Ident) * SynExpr option val BindOriginalRecdExpr: - withExpr: SynExpr * BlockSeparator -> - mkRecdExpr: ((SynExpr * BlockSeparator) option -> SynExpr) -> - tcExpr: (SynExpr -> Expr * UnscopedTyparEnv) -> - Expr * UnscopedTyparEnv + withExpr: SynExpr * BlockSeparator -> mkRecdExpr: ((SynExpr * BlockSeparator) option -> SynExpr) -> SynExpr