Checker: recover on unknown record fields (#15214)

Author: auduchinok

src/Compiler/Checking/CheckExpressions.fs

@@ -1807,10 +1807,17 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: ((Ident list * Ident) * '
     let fldResolutions =
         let allFields = flds |> List.map (fun ((_, ident), _) -> ident)
         flds
-        |> List.map (fun (fld, fldExpr) ->
-            let (fldPath, fldId) = fld
-            let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fldPath fldId allFields
-            fld, frefSet, fldExpr)
+        |> List.choose (fun (fld, fldExpr) ->
+            try
+                let fldPath, fldId = fld
+                let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fldPath fldId allFields
+                Some(fld, frefSet, fldExpr)
+            with e ->
+                errorRecoveryNoRange e
+                None
+        )
+
+    if fldResolutions.IsEmpty then None else
 
     let relevantTypeSets =
         fldResolutions |> List.map (fun (_, frefSet, _) ->
@@ -1870,7 +1877,7 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: ((Ident list * Ident) * '
                         Map.add fref2.FieldName fldExpr fs, (fref2.FieldName, fldExpr) :: rfldsList
 
                 | _ -> error(Error(FSComp.SR.tcRecordFieldInconsistentTypes(), m)))
-    tinst, tcref, fldsmap, List.rev rfldsList
+    Some(tinst, tcref, fldsmap, List.rev rfldsList)
 
 let rec ApplyUnionCaseOrExn (makerForUnionCase, makerForExnTag) m (cenv: cenv) env overallTy item =
     let g = cenv.g
@@ -7362,7 +7369,10 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
         match flds with
         | [] -> []
         | _ ->
-            let tinst, tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr
+            match BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr with
+            | None -> []
+            | Some(tinst, tcref, _, fldsList) ->
+
             let gtyp = mkAppTy tcref tinst
             UnifyTypes cenv env mWholeExpr overallTy gtyp
 
@@ -7393,7 +7403,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
             error(Error(errorInfo, mWholeExpr))
 
         if isFSharpObjModelTy g overallTy then errorR(Error(FSComp.SR.tcTypeIsNotARecordTypeNeedConstructor(), mWholeExpr))
-        elif not (isRecdTy g overallTy) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))
+        elif not (isRecdTy g overallTy || fldsList.IsEmpty) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))
 
     let superInitExprOpt , tpenv =
         match inherits, GetSuperTypeOfType g cenv.amap mWholeExpr overallTy with
@@ -7411,14 +7421,18 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
             errorR(InternalError("Unexpected failure in getting super type", mWholeExpr))
             None, tpenv
 
-    let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv withExprInfoOpt overallTy fldsList mWholeExpr
+    if fldsList.IsEmpty && isTyparTy g overallTy then
+        SolveTypeAsError env.DisplayEnv cenv.css mWholeExpr overallTy
+        mkDefault (mWholeExpr, overallTy), tpenv
+    else
+        let expr, tpenv = TcRecordConstruction cenv overallTy env tpenv withExprInfoOpt overallTy fldsList mWholeExpr
 
-    let expr =
-        match superInitExprOpt  with
-        | _ when isStructTy g overallTy -> expr
-        | Some superInitExpr  -> mkCompGenSequential mWholeExpr superInitExpr  expr
-        | None -> expr
-    expr, tpenv
+        let expr =
+            match superInitExprOpt  with
+            | _ when isStructTy g overallTy -> expr
+            | Some superInitExpr  -> mkCompGenSequential mWholeExpr superInitExpr  expr
+            | None -> expr
+        expr, tpenv
 
 
 // Check '{| .... |}'

src/Compiler/Checking/CheckExpressions.fsi

@@ -895,7 +895,7 @@ val BuildFieldMap:
     ty: TType ->
     flds: ((Ident list * Ident) * 'T) list ->
     m: range ->
-        TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list
+        (TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list) option
 
 /// Check a long identifier 'Case' or 'Case argsR' that has been resolved to an active pattern case
 val TcPatLongIdentActivePatternCase:

src/Compiler/Checking/CheckPatterns.fs

@@ -435,7 +435,10 @@ and TcPatArrayOrList warnOnUpper cenv env vFlags patEnv ty isArray args m =
 
 and TcRecordPat warnOnUpper cenv env vFlags patEnv ty fieldPats m =
     let fieldPats = fieldPats |> List.map (fun (fieldId, _, fieldPat) -> fieldId, fieldPat)
-    let tinst, tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty fieldPats m
+    match BuildFieldMap cenv env true ty fieldPats m with
+    | None -> (fun _ -> TPat_error m), patEnv
+    | Some(tinst, tcref, fldsmap, _fldsList) ->
+
     let gtyp = mkAppTy tcref tinst
     let inst = List.zip (tcref.Typars m) tinst
 

tests/FSharp.Compiler.ComponentTests/ErrorMessages/NameResolutionTests.fs

@@ -21,8 +21,10 @@ let r:F = { Size=3; Height=4; Wall=1 }
         """
         |> typecheck
         |> shouldFail
-        |> withSingleDiagnostic (Error 1129, Line 9, Col 31, Line 9, Col 35,
-                                 ("The record type 'F' does not contain a label 'Wall'. Maybe you want one of the following:" + System.Environment.NewLine + "   Wallis"))
+        |> withDiagnostics [
+            (Error 1129, Line 9, Col 31, Line 9, Col 35, "The record type 'F' does not contain a label 'Wall'. Maybe you want one of the following:" + System.Environment.NewLine + "   Wallis")
+            (Error 764, Line 9, Col 11, Line 9, Col 39, "No assignment given for field 'Wallis' of type 'Test.F'")
+        ]
 
     [<Fact>]
     let RecordFieldProposal () =
@@ -38,5 +40,7 @@ let r = { Size=3; Height=4; Wall=1 }
         """
         |> typecheck
         |> shouldFail
-        |> withSingleDiagnostic (Error 39, Line 9, Col 29, Line 9, Col 33,
-                                 ("The record label 'Wall' is not defined. Maybe you want one of the following:" + System.Environment.NewLine + "   Walls" + System.Environment.NewLine + "   Wallis"))
+        |> withDiagnostics [
+            (Error 39, Line 9, Col 29, Line 9, Col 33, "The record label 'Wall' is not defined. Maybe you want one of the following:" + System.Environment.NewLine + "   Walls" + System.Environment.NewLine + "   Wallis")
+            (Error 764, Line 9, Col 9, Line 9, Col 37, "No assignment given for field 'Wallis' of type 'Test.F'")
+        ]

tests/FSharp.Compiler.ComponentTests/ErrorMessages/SuggestionsTests.fs

@@ -173,8 +173,10 @@ let r = { Field1 = "hallo"; Field2 = 1 }
         """
         |> typecheck
         |> shouldFail
-        |> withSingleDiagnostic (Error 39, Line 8, Col 11, Line 8, Col 17,
-                                 ("The record label 'Field1' is not defined. Maybe you want one of the following:" + Environment.NewLine + "   MyRecord.Field1"))
+        |> withDiagnostics [
+            (Error 39, Line 8, Col 11, Line 8, Col 17, "The record label 'Field1' is not defined. Maybe you want one of the following:" + Environment.NewLine + "   MyRecord.Field1")
+            (Error 39, Line 8, Col 29, Line 8, Col 35, "The record label 'Field2' is not defined. Maybe you want one of the following:" + Environment.NewLine + "   MyRecord.Field2")
+        ]
 
     [<Fact>]
     let ``Suggest Type Parameters`` () =

tests/fsharp/typecheck/sigs/neg07.bsl

@@ -24,9 +24,19 @@ neg07.fs(36,11,36,27): typecheck error FS0026: This rule will never be matched
 neg07.fs(46,15,46,27): typecheck error FS0039: The record label 'RecordLabel1' is not defined. Maybe you want one of the following:
    R.RecordLabel1
 
+neg07.fs(46,33,46,45): typecheck error FS0039: The record label 'RecordLabel2' is not defined. Maybe you want one of the following:
+   R.RecordLabel2
+
+neg07.fs(47,17,47,55): typecheck error FS0025: Incomplete pattern matches on this expression.
+neg07.fs(47,59,47,60): typecheck error FS0039: The value or constructor 'a' is not defined.
+neg07.fs(47,63,47,64): typecheck error FS0039: The value or constructor 'b' is not defined.
+
 neg07.fs(47,19,47,31): typecheck error FS0039: The record label 'RecordLabel1' is not defined. Maybe you want one of the following:
    R.RecordLabel1
 
+neg07.fs(47,37,47,49): typecheck error FS0039: The record label 'RecordLabel2' is not defined. Maybe you want one of the following:
+   R.RecordLabel2
+
 neg07.fs(57,10,57,17): typecheck error FS1196: The 'UseNullAsTrueValue' attribute flag may only be used with union types that have one nullary case and at least one non-nullary case
 
 neg07.fs(64,10,64,18): typecheck error FS1196: The 'UseNullAsTrueValue' attribute flag may only be used with union types that have one nullary case and at least one non-nullary case

tests/fsharpqa/Source/Conformance/InferenceProcedures/NameResolution/RequireQualifiedAccess/E_OnRecord.fs

@@ -2,7 +2,6 @@
 // Verify error when not fully qualifying a record field when it
 // has the RequireQualifiedAccess attribute.
 
-//<Expects id="FS0039" status="error">The record label 'Field1' is not defined\.</Expects>
 //<Expects id="FS0039" status="error">The record label 'Field1' is not defined\.</Expects>
 
 [<RequireQualifiedAccess>]

tests/service/Symbols.fs

@@ -474,3 +474,96 @@ type Foo =
           (:? FSharpMemberOrFunctionOrValue as setMfv) ->
             Assert.AreNotEqual(getMfv.CurriedParameterGroups, setMfv.CurriedParameterGroups)
         | _ -> Assert.Fail "Expected symbols to be FSharpMemberOrFunctionOrValue"
+
+module Expressions =
+    [<Test>]
+    let ``Unresolved record field 01`` () =
+        let _, checkResults = getParseAndCheckResults """
+type R =
+    { F1: int
+      F2: int }
+
+{ F = 1
+  F2 = 1 }
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true
+
+    [<Test>]
+    let ``Unresolved record field 02`` () =
+        let _, checkResults = getParseAndCheckResults """
+[<RequireQualifiedAccess>]
+type R =
+    { F1: int
+      F2: int }
+
+{ F1 = 1
+  R.F2 = 1 }
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true
+
+    [<Test>]
+    let ``Unresolved record field 03`` () =
+        let _, checkResults = getParseAndCheckResults """
+[<RequireQualifiedAccess>]
+type R =
+    { F1: int
+      F2: int }
+
+{ R.F2 = 1
+  F1 = 1 }
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true
+
+    [<Test>]
+    let ``Unresolved record field 04`` () =
+        let _, checkResults = getParseAndCheckResults """
+type R =
+    { F1: int
+      F2: int }
+
+match Unchecked.defaultof<R> with
+{ F = 1
+  F2 = 1 } -> ()
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true
+
+    [<Test>]
+    let ``Unresolved record field 05`` () =
+        let _, checkResults = getParseAndCheckResults """
+[<RequireQualifiedAccess>]
+type R =
+    { F1: int
+      F2: int }
+
+match Unchecked.defaultof<R> with
+{ F = 1
+  R.F2 = 1 } -> ()
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true
+
+
+    [<Test>]
+    let ``Unresolved record field 06`` () =
+        let _, checkResults = getParseAndCheckResults """
+[<RequireQualifiedAccess>]
+type R =
+    { F1: int
+      F2: int }
+
+match Unchecked.defaultof<R> with
+{ R.F2 = 1
+  F = 1 } -> ()
+"""
+        getSymbolUses checkResults
+        |> Seq.exists (fun symbolUse -> symbolUse.IsFromUse && symbolUse.Symbol.DisplayName = "F2")
+        |> shouldEqual true