[WIP] Nested Record Field Copy and Update Expression

src/fsharp/NameResolution.fs

@@ -3137,6 +3137,109 @@ let ResolveFieldPrim sink (ncenv:NameResolver) nenv ad ty (mp,id:Ident) allField
 
         [(resInfo,item)]
 
+/// Resolve a long identifier representing a nested record field
+let ResolveNestedField sink (ncenv:NameResolver) nenv ad ty (lid : Ident list) =
+    let typeNameResInfo = TypeNameResolutionInfo.Default
+    let g = ncenv.g
+
+    let lookupFld ty (id : Ident) =
+        let m = id.idRange
+        let otherRecdFlds ty =
+            let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv ty
+            [
+                for KeyValue(_, v) in nenv.eFieldLabels do
+                    let fldOpt = v |> List.tryFind (fun r -> r.TyconRef.DisplayName = typeName)
+                    match fldOpt with
+                    | Some rfref -> yield rfref.RecdField.Id
+                    | None  -> () 
+            ]
+
+        let lookup() =
+            let frefs = 
+                try Map.find id.idText nenv.eFieldLabels |> success
+                with :? KeyNotFoundException ->
+                    // record label is unknown -> suggest related labels and give a hint to the user
+                    raze (SuggestLabelsOfRelatedRecords g nenv id (otherRecdFlds ty))
+
+            // Eliminate duplicates arising from multiple 'open' 
+            frefs 
+            |?> ListSet.setify (fun fref1 fref2 -> tyconRefEq g fref1.TyconRef fref2.TyconRef)
+            |?> List.map (fun x -> FieldResolution(x,false))
+
+        if isAppTy g ty then 
+            match ncenv.InfoReader.TryFindRecdOrClassFieldInfoOfType(id.idText,m,ty) with
+            | Some (RecdFieldInfo(_,rfref)) -> success [FieldResolution(rfref,false)]
+            | None ->
+                if isRecdTy g ty then
+                    // record label doesn't belong to record type -> suggest other labels of same record
+                    let suggestLabels() = SuggestOtherLabelsOfSameRecordType g nenv ty id (otherRecdFlds ty)
+                    let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv ty
+                    let errorText = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName,id.idText)
+                    raze (ErrorWithSuggestions(errorText, m, id.idText, suggestLabels))
+                else
+                    lookup()
+        else 
+            lookup()
+
+    let access, flds =
+        match lid with
+        | [] -> [], []
+        | [id] -> [], lookupFld ty id |> ForceRaise
+        | id :: _ ->
+            let fldSearch () =
+                match lid with
+                | id :: rest ->
+                    let fldSearch = lookupFld ty id
+                    let fldSearch = fldSearch |?> List.map (fun (FieldResolution(rfref, dep)) -> FieldResolution(rfref, dep), rfref.FieldName, rfref.FormalType, rest)
+                    fldSearch
+                | _ -> NoResultsOrUsefulErrors
+
+            let tyconSearch ad () =
+                match lid with
+                | tn :: id :: rest ->
+                    let m = tn.idRange
+                    let tcrefs = LookupTypeNameInEnvNoArity OpenQualified tn.idText nenv
+                    if isNil tcrefs then NoResultsOrUsefulErrors else
+                    let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref))
+                    let tyconSearch = ResolveLongIdentInTyconRefs ResultCollectionSettings.AllResults ncenv nenv LookupKind.RecdField 1 m ad id rest typeNameResInfo tn.idRange tcrefs
+                    let tyconSearch = tyconSearch |?> List.choose (function (_, Item.RecdField(RecdFieldInfo(_,rfref)), rest) -> Some(FieldResolution(rfref,false), rfref.FieldName, rfref.FormalType, rest) | _ -> None)
+                    tyconSearch
+                | _ -> NoResultsOrUsefulErrors
+
+            let moduleOrNsSearch ad () =
+                match lid with
+                | [] -> NoResultsOrUsefulErrors
+                | id :: rest ->
+                    let m = id.idRange
+                    let t = ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m OpenQualified nenv ad id rest false
+                                (ResolveFieldInModuleOrNamespace ncenv nenv ad)
+                    t |?> List.map (fun (_, FieldResolution(rfref, dep), rest) -> (FieldResolution(rfref, dep), rfref.FieldName, rfref.FormalType, rest))
+
+            let item, fldIdText, fldTy, rest =
+                fldSearch () +++ moduleOrNsSearch ad +++ tyconSearch ad +++ moduleOrNsSearch AccessibleFromSomeFSharpCode +++ tyconSearch AccessibleFromSomeFSharpCode
+                |> AtMostOneResult id.idRange
+                |> ForceRaise
+
+            let idsBeforeField = lid |> List.takeWhile (fun id -> id.idText <> fldIdText)
+
+            match rest with
+            | [] -> idsBeforeField, [item]
+            | _ ->  
+                let rec nestedFieldSearch flds ty =
+                    function
+                    | [] -> flds
+                    | id :: rest -> 
+                        let resolved = lookupFld ty id |> ForceRaise
+                        let fldTy =
+                            match resolved with
+                            | [FieldResolution(rfref, _)] -> rfref.FormalType
+                            | _ -> ty
+                        nestedFieldSearch (flds @ resolved) fldTy rest
+
+                idsBeforeField, item::(nestedFieldSearch [] fldTy rest)
+
+    access, flds |> List.map (fun (FieldResolution(rfref, _)) -> lid |> List.find (fun id -> id.idText = rfref.FieldName))
+
 let ResolveField sink ncenv nenv ad ty (mp,id) allFields =
     let res = ResolveFieldPrim sink ncenv nenv ad ty (mp,id) allFields
     // Register the results of any field paths "Module.Type" in "Module.Type.field" as a name resolution. (Note, the path resolution

src/fsharp/NameResolution.fsi

@@ -481,6 +481,9 @@ val internal ResolveTypeLongIdentInTyconRef         : TcResultsSink -> NameResol
 /// Resolve a long identifier to a type definition
 val internal ResolveTypeLongIdent                   : TcResultsSink -> NameResolver -> ItemOccurence -> FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident list -> TypeNameResolutionStaticArgsInfo -> PermitDirectReferenceToGeneratedType -> ResultOrException<TyconRef>
 
+/// Resolve a long identifier to a nested field
+val internal ResolveNestedField                     : TcResultsSink -> NameResolver -> NameResolutionEnv -> AccessorDomain -> TType -> Ident list -> Ident list * Ident list
+
 /// Resolve a long identifier to a field
 val internal ResolveField                           : TcResultsSink -> NameResolver -> NameResolutionEnv -> AccessorDomain -> TType -> Ident list * Ident -> Ident list -> FieldResolution list
 

src/fsharp/TypeChecker.fs

@@ -6898,10 +6898,85 @@ and TcAssertExpr cenv overallTy env (m:range) tpenv x  =
 //------------------------------------------------------------------------- 
 
 and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) =
+    let buildForNestdFlds (lidwd : LongIdentWithDots) v =
+        let recdExprCopyInfo ids (optOrigExpr : (SynExpr * BlockSeparator) option) (id : Ident) =
+            let upToId origSepRng id lidwd =
+                let rec buildLid res (id : Ident) =
+                    function
+                    | [] -> res
+                    | (h : Ident) :: t -> if h.idText = id.idText then h :: res else buildLid (h :: res) id t
+
+                let rec combineIds =
+                    function
+                    | [] | [_] -> []
+                    | id1::id2::rest -> (id1, id2) :: (id2 :: rest |> combineIds)
+
+                let calcLidSeparatorRanges lid =
+                    match lid with
+                    | [] | [_] -> [origSepRng]
+                    | _ :: t -> origSepRng :: List.map (fun (s : Ident, e : Ident) -> mkRange s.idRange.FileName s.idRange.End e.idRange.Start) t
+
+                let lid = buildLid [] id lidwd |> List.rev
+
+                (lid, lid |> combineIds |> calcLidSeparatorRanges)
+
+            let totalRange (origId : Ident) (id : Ident) =
+                mkRange origId.idRange.FileName origId.idRange.End id.idRange.Start
+
+            match optOrigExpr with 
+            | Some (SynExpr.Ident origId, (sepRange, _)) ->
+                let lid, rng = upToId sepRange id (origId :: ids)
+                Some (SynExpr.LongIdent (false, LongIdentWithDots(lid, rng), None, totalRange origId id), (id.idRange, None)) // TODO: id.idRange should be the range of the next separator
+            | _ -> None
+
+
+        let rec synExprRecd copyInfo id flds =
+            Some(SynExpr.Record((None, (copyInfo id), [ match flds with 
+                                                        | [] -> yield ((LongIdentWithDots ([], []), true), v, None)
+                                                        | [fldId] -> yield ((LongIdentWithDots ([fldId],[]), true), v, None)
+                                                        | fldId :: rest -> 
+                                                            let nestedFld = synExprRecd copyInfo fldId
+                                                            yield ((LongIdentWithDots ([fldId], []), true), nestedFld rest, None)], id.idRange)))
+
+        let access, flds = lidwd.Lid |> ResolveNestedField cenv.tcSink cenv.nameResolver env.eNameResEnv env.eAccessRights overallTy
+
+        let expanded =
+            [
+                match (access, flds) with
+                | [],  [] -> ()
+                | accessIds, [] -> yield (accessIds |> List.frontAndBack), v
+                | accessIds, [fldId] -> yield ((accessIds@[fldId]) |> List.frontAndBack), v
+                | accessIds, fldId :: rest ->
+                    yield (accessIds, fldId), synExprRecd (recdExprCopyInfo flds optOrigExpr) fldId rest
+            ]
+
+        expanded
+
+    let reduceNstdUpdates flds =
+        let grpdByFld = flds |> List.groupBy (fun ((_, fld : Ident), _) -> fld.idText)
+        [
+            for (_, flds) in grpdByFld do
+                if (flds |> List.length < 2) then 
+                    yield! flds
+                else
+                    let rec grpIfNstd res xs =
+                        match xs with
+                        | [] -> res
+                        | x::[] -> x :: res 
+                        | x::y::ys -> match x, y with
+                                      | (lidwid, Some(SynExpr.Record (aBI, aCI, aFlds, aRng))), (_, Some(SynExpr.Record (_, _, bFlds, _))) ->
+                                            let combinedFlds = aFlds @ bFlds
+                                            let reducedRecd = (lidwid, Some(SynExpr.Record (aBI, aCI, combinedFlds, aRng))) 
+                                            grpIfNstd (reducedRecd :: res) ys
+                                      | _ -> grpIfNstd (x :: res) (y :: ys)
+
+                    yield! flds |> grpIfNstd []
+        ]
 
     let requiresCtor = (GetCtorShapeCounter env = 1) // Get special expression forms for constructors 
     let haveCtor = Option.isSome inherits
 
+
     let optOrigExprInfo, tpenv = 
       match optOrigExpr with 
       | None -> None, tpenv 
@@ -6915,7 +6990,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
 
     let hasOrigExpr = optOrigExprInfo.IsSome
 
-    let fldsList = 
+    let fldsList =     
         let flds = 
             [
                 // if we met at least one field that is not syntactically correct - raise ReportedError to transfer control to the recovery routine
@@ -6925,9 +7000,12 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr
                         // we assume that parse errors were already reported
                         raise (ReportedError None)
 
-                    yield (List.frontAndBack lidwd.Lid, v)
-            ]
-
+                    match lidwd.Lid with
+                    | [] -> ()
+                    | [id] -> yield (([], id), v)
+                    | _ -> yield! buildForNestdFlds lidwd v                 
+            ] |> reduceNstdUpdates
+
         match flds with 
         | [] -> []
         | _ ->

src/fsharp/tast.fs

@@ -3884,6 +3884,9 @@ and
     /// Get the signature range of the record field 
     member x.SigRange = x.RecdField.SigRange
 
+    /// The type of the record field
+    member x.FormalType = x.RecdField.FormalType
+
     member x.Index =
         let (RFRef(tcref,id)) = x
         try 

tests/fsharpqa/Source/Conformance/BasicTypeAndModuleDefinitions/RecordTypes/E_NestedUpdateRecordCloning01.fs

@@ -0,0 +1,14 @@
+// #Regression #Conformance #TypesAndModules #Records
+// Verify same field cannot be declared twice in a nested field update
+//<Expects id="FS0668" status="error">The field 'A' appears twice in this record expression or pattern</Expects>
+#light
+
+type AnotherNestedRecTy = { A : int; }
+
+type NestdRecTy = { B : string; C : AnotherNestedRecTy; }
+
+type RecTy = { D : NestdRecTy; E : string option; }
+
+let t1 = { D = { B = "t1"; C = { A = 1; } }; E = None; }
+
+let t2 = { t1 with D.C.A = 3; D.C.A = 2}

tests/fsharpqa/Source/Conformance/BasicTypeAndModuleDefinitions/RecordTypes/NestedUpdateRecordCloning01.fs

@@ -0,0 +1,30 @@
+// #Conformance #TypesAndModules #Records
+#light
+
+// Verify cloning and updating of fields using nested copy and update syntax
+
+type AnotherNestedRecTy = { A : int; }
+
+type NestdRecTy = { B : string; C : AnotherNestedRecTy; }
+
+type RecTy = { D : NestdRecTy; E : string option; }
+
+let t1 = { D = { B = "t1"; C = { A = 1; } }; E = None; }
+
+let t2 = { t1 with D.B = "t2" }
+
+let t3 = { t2 with D.C.A = 3 }
+
+// Changed fields t1 to t2
+if t1.D.B <> "t1" || t2.D.B <> "t2" then exit 1
+
+// Fields cloned t1 to t2
+if t1.E <> t2.E || t1.D.C <> t2.D.C then exit 1
+
+// Changed fields t2 to t3
+if t2.D.C.A <> 1 || t3.D.C.A <> 3 then exit 1
+
+// Fields cloned t2 to t3
+if t2.E <> t3.E || t2.D.B <> t3.D.B then exit 1
+
+exit 0

tests/fsharpqa/Source/Conformance/BasicTypeAndModuleDefinitions/RecordTypes/NestedUpdateRecordCloning02.fs

@@ -0,0 +1,31 @@
+// #Conformance #TypesAndModules #Records
+#light
+
+// Verify cloning and updating of fields accessed through TypeName using nested copy and update syntax
+
+type AnotherNestedRecTy = { A : int; }
+
+type NestdRecTy = { B : string; C : AnotherNestedRecTy; }
+
+type RecTy = { D : NestdRecTy; E : string option; }
+
+let t1 = { D = { B = "t1"; C = { A = 1; } }; E = None; }
+
+// TypeName.FieldName access
+let t2 = { t1 with RecTy.D.B = "t2"; }
+
+let t3 = { t2 with RecTy.D.B = "t3"; RecTy.D.C.A = 3; }
+
+// Changed Fields t1 to t2
+if t1.D.B <> "t1" || t2.D.B <> "t2" then exit 1
+
+// Fields Cloned t1 to t2
+if t2.D.C.A <> t1.D.C.A || t2.E <> t1.E then exit 1
+
+// Changed Fields t2 to t3
+if t3.D.B <> "t3" || t2.D.C.A <> 1 || t3.D.C.A <> 3 then exit 1
+
+// Fields Cloned t2 to t3
+if t3.E <> t2.E then exit 1
+
+exit 0

tests/fsharpqa/Source/Conformance/BasicTypeAndModuleDefinitions/RecordTypes/NestedUpdateRecordCloning03.fs

@@ -0,0 +1,32 @@
+// #Conformance #TypesAndModules #Records
+#light
+
+// Verify cloning and updating of fields with ambiguities between TypeName and FieldName using nested copy and update syntax
+
+type AnotherNestedRecTy = { A : int; }
+
+type NestdRecTy = { B : string; AnotherNestedRecTy : AnotherNestedRecTy; }
+
+type RecTy = { NestdRecTy : NestdRecTy; E : string option; }
+
+
+let t1 = { RecTy.NestdRecTy = { B = "t1"; AnotherNestedRecTy = { A = 1; } }; E = None; }
+
+// Ambiguous access
+let t2 = { t1 with NestdRecTy.B = "t2" }
+
+let t3 = { t2 with NestdRecTy.AnotherNestedRecTy.A = 3 }
+
+// Changed Fields t1 to t2
+if t1.NestdRecTy.B <> "t1" || t2.NestdRecTy.B <> "t2" then exit 1
+
+// Fields Cloned t1 to t2
+if t2.E <> t1.E || t2.NestdRecTy.AnotherNestedRecTy.A <> t1.NestdRecTy.AnotherNestedRecTy.A then exit 1
+
+// Changed Fields t2 to t3
+if t3.NestdRecTy.AnotherNestedRecTy.A <> 3 then exit 1
+
+// Fields Cloned t2 to t3
+if t3.E <> t2.E || t3.NestdRecTy.B <> t2.NestdRecTy.B then exit 1
+
+exit 0

tests/fsharpqa/Source/Conformance/BasicTypeAndModuleDefinitions/RecordTypes/NestedUpdateRecordCloning04.fs

@@ -0,0 +1,34 @@
+// #Conformance #TypesAndModules #Records
+#light
+
+// Verify cloning and updating of fields accessed through ModuleName using nested copy and update syntax
+module Test =
+    module M =
+        type AnotherNestedRecTy = { A : int; }
+
+        type NestdRecTy = { B : string; C : AnotherNestedRecTy; }
+
+        type RecTy = { D : NestdRecTy; E : string option; }
+
+
+    let t1 = { M.RecTy.D = { M.B = "t1"; M.C = { M.A = 1; } }; M.E = None; }
+
+    // Module.FieldName access
+    let t2 = { t1 with M.D.B = "t2"; M.D.C.A = 2; }
+
+    // Module.TypeName.FieldName access
+    let t3 = { t2 with M.RecTy.E = Some "t3"; M.RecTy.D.B = "t3"; }
+
+    // Changed Fields t1 to t2
+    if t1.D.B <> "t1" || t2.D.B <> "t2" || t2.D.C.A <> 2 || t1.D.C.A <> 1 then exit 1
+
+    // Fields Cloned t1 to t2
+    if t2.E <> t1.E then exit 1
+
+    // Changed Fields t2 to t3
+    if t2.E <> None || t3.E <> Some "t3" || t3.D.B <> "t3" then exit 1
+
+    // Fields Cloned t2 to t3
+    if t3.D.C <> t2.D.C then exit 1
+
+    exit 0