Skip to content

Fix: 14814 --- Inaccurate error in anonymous record copy-and-update #15625

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Jul 19, 2023
Merged

Fix: 14814 --- Inaccurate error in anonymous record copy-and-update #15625

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
42 changes: 14 additions & 28 deletions src/Compiler/Checking/CheckExpressions.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1809,17 +1809,10 @@ let BuildFieldMap (cenv: cenv) env isPartial ty (flds: ((Ident list * Ident) * '
let fldResolutions =
let allFields = flds |> List.map (fun ((_, ident), _) -> ident)
flds
|> 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
|> 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)

let relevantTypeSets =
fldResolutions |> List.map (fun (_, frefSet, _) ->
Expand Down Expand Up @@ -1879,7 +1872,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)))
Some(tinst, tcref, fldsmap, List.rev rfldsList)
tinst, tcref, fldsmap, List.rev rfldsList

let rec ApplyUnionCaseOrExn (makerForUnionCase, makerForExnTag) m (cenv: cenv) env overallTy item =
let g = cenv.g
Expand Down Expand Up @@ -7377,10 +7370,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
match flds with
| [] -> []
| _ ->
match BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr with
| None -> []
| Some(tinst, tcref, _, fldsList) ->

let tinst, tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr
let gtyp = mkAppTy tcref tinst
UnifyTypes cenv env mWholeExpr overallTy gtyp

Expand Down Expand Up @@ -7411,7 +7401,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 || fldsList.IsEmpty) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))
elif not (isRecdTy g overallTy) then errorR(Error(FSComp.SR.tcTypeIsNotARecordType(), mWholeExpr))

let superInitExprOpt , tpenv =
match inherits, GetSuperTypeOfType g cenv.amap mWholeExpr overallTy with
Expand All @@ -7429,18 +7419,14 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, withExprOpt, synRecdFields, m
errorR(InternalError("Unexpected failure in getting super type", mWholeExpr))
None, tpenv

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, 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 '{| .... |}'
Expand Down
2 changes: 1 addition & 1 deletion src/Compiler/Checking/CheckExpressions.fsi
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -895,7 +895,7 @@ val BuildFieldMap:
ty: TType ->
flds: ((Ident list * Ident) * 'T) list ->
m: range ->
(TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list) option
TypeInst * TyconRef * Map<string, 'T> * (string * 'T) list

/// Check a long identifier 'Case' or 'Case argsR' that has been resolved to an active pattern case
val TcPatLongIdentActivePatternCase:
Expand Down
5 changes: 1 addition & 4 deletions src/Compiler/Checking/CheckPatterns.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -441,10 +441,7 @@ 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)
match BuildFieldMap cenv env true ty fieldPats m with
| None -> (fun _ -> TPat_error m), patEnv
| Some(tinst, tcref, fldsmap, _fldsList) ->

let tinst, tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty fieldPats m
let gtyp = mkAppTy tcref tinst
let inst = List.zip (tcref.Typars m) tinst

Expand Down
262 changes: 4 additions & 258 deletions tests/FSharp.Compiler.ComponentTests/ErrorMessages/NameResolutionTests.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,10 +21,8 @@ let r:F = { Size=3; Height=4; Wall=1 }
"""
|> typecheck
|> shouldFail
|> 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'")
]
|> 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"))

[<Fact>]
let RecordFieldProposal () =
Expand All @@ -40,257 +38,5 @@ let r = { Size=3; Height=4; Wall=1 }
"""
|> typecheck
|> shouldFail
|> 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'")
]

let multipleRecdTypeChoiceWarningWith1AlternativeSource = """
namespace N

module Module1 =

type OtherThing =
{ Name: string }

module Module2 =

type Person =
{ Name: string
City: string }

module Lib =

open Module2
open Module1

let F thing =
let x = thing.Name
thing.City
"""

[<Fact>]
let MultipleRecdTypeChoiceWarningWith1AlternativeLangPreview () =
FSharp multipleRecdTypeChoiceWarningWith1AlternativeSource
|> withLangVersionPreview
|> typecheck
|> shouldFail
|> withDiagnostics [
(Warning 3566, Line 22, Col 9, Line 22, Col 19, "Multiple type matches were found:\n N.Module1.OtherThing\n N.Module2.Person\nThe type 'N.Module1.OtherThing' was used. Due to the overlapping field names\n Name\nconsider using type annotations or change the order of open statements.")
(Error 39, Line 22, Col 15, Line 22, Col 19, "The type 'OtherThing' does not define the field, constructor or member 'City'.")
]

[<Fact>]
let MultipleRecdTypeChoiceWarningWith1AlternativeLang7 () =
FSharp multipleRecdTypeChoiceWarningWith1AlternativeSource
|> withLangVersion70
|> typecheck
|> shouldFail
|> withDiagnostics [
(Information 3566, Line 22, Col 9, Line 22, Col 19, "Multiple type matches were found:\n N.Module1.OtherThing\n N.Module2.Person\nThe type 'N.Module1.OtherThing' was used. Due to the overlapping field names\n Name\nconsider using type annotations or change the order of open statements.")
(Error 39, Line 22, Col 15, Line 22, Col 19, "The type 'OtherThing' does not define the field, constructor or member 'City'.")
]

let multipleRecdTypeChoiceWarningWith2AlternativeSource = """
namespace N

module Module1 =

type OtherThing =
{ Name: string
Planet: string }

module Module2 =

type Person =
{ Name: string
City: string
Planet: string }

module Module3 =

type Cafe =
{ Name: string
City: string
Country: string
Planet: string }

module Lib =

open Module3
open Module2
open Module1

let F thing =
let x = thing.Name
thing.City
"""

[<Fact>]
let MultipleRecdTypeChoiceWarningWith2AlternativeLangPreview () =
FSharp multipleRecdTypeChoiceWarningWith2AlternativeSource
|> withLangVersionPreview
|> typecheck
|> shouldFail
|> withDiagnostics [
(Warning 3566, Line 33, Col 9, Line 33, Col 19, "Multiple type matches were found:\n N.Module1.OtherThing\n N.Module2.Person\n N.Module3.Cafe\nThe type 'N.Module1.OtherThing' was used. Due to the overlapping field names\n Name\n Planet\nconsider using type annotations or change the order of open statements.")
(Error 39, Line 33, Col 15, Line 33, Col 19, "The type 'OtherThing' does not define the field, constructor or member 'City'.")
]

[<Fact>]
let MultipleRecdTypeChoiceWarningWith2AlternativeLang7 () =
FSharp multipleRecdTypeChoiceWarningWith2AlternativeSource
|> withLangVersion70
|> typecheck
|> shouldFail
|> withDiagnostics [
(Information 3566, Line 33, Col 9, Line 33, Col 19, "Multiple type matches were found:\n N.Module1.OtherThing\n N.Module2.Person\n N.Module3.Cafe\nThe type 'N.Module1.OtherThing' was used. Due to the overlapping field names\n Name\n Planet\nconsider using type annotations or change the order of open statements.")
(Error 39, Line 33, Col 15, Line 33, Col 19, "The type 'OtherThing' does not define the field, constructor or member 'City'.")
]

let multipleRecdTypeChoiceWarningNotRaisedWithCorrectOpenStmtsOrderingSource = """
namespace N

module Module1 =

type OtherThing =
{ Name: string
Planet: string }

module Module2 =

type Person =
{ Name: string
City: string
Planet: string }

module Module3 =

type Cafe =
{ Name: string
City: string
Country: string
Planet: string }

module Lib =

open Module3
open Module1
open Module2

let F thing =
let x = thing.Name
thing.City
"""

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithCorrectOpenStmtsOrderingLangPreview () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithCorrectOpenStmtsOrderingSource
|> withLangVersionPreview
|> typecheck
|> shouldSucceed

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithCorrectOpenStmtsOrderingLang7 () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithCorrectOpenStmtsOrderingSource
|> withLangVersion70
|> typecheck
|> shouldSucceed

let multipleRecdTypeChoiceWarningNotRaisedWithoutOverlapsSource = """
namespace N

module Module1 =

type OtherThing =
{ NameX: string
Planet: string }

module Module2 =

type Person =
{ Name: string
City: string
Planet: string }

module Module3 =

type Cafe =
{ NameX: string
City: string
Country: string
Planet: string }

module Lib =

open Module3
open Module2
open Module1

let F thing =
let x = thing.Name
thing.City
"""

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithoutOverlapsLangPreview () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithoutOverlapsSource
|> withLangVersionPreview
|> typecheck
|> shouldSucceed

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithoutOverlapsLang7 () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithoutOverlapsSource
|> withLangVersion70
|> typecheck
|> shouldSucceed

let multipleRecdTypeChoiceWarningNotRaisedWithTypeAnnotationsSource = """
namespace N

module Module1 =

type OtherThing =
{ NameX: string
Planet: string }

module Module2 =

type Person =
{ Name: string
City: string
Planet: string }

module Module3 =

type Cafe =
{ NameX: string
City: string
Country: string
Planet: string }

module Lib =

open Module3
open Module2
open Module1

let F (thing: Person) =
let x = thing.Name
thing.City
"""

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithTypeAnnotationsLangPreview () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithTypeAnnotationsSource
|> withLangVersionPreview
|> typecheck
|> shouldSucceed

[<Fact>]
let MultipleRecdTypeChoiceWarningNotRaisedWithTypeAnnotationsLang7 () =
FSharp multipleRecdTypeChoiceWarningNotRaisedWithTypeAnnotationsSource
|> withLangVersion70
|> typecheck
|> shouldSucceed
|> 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"))
6 changes: 2 additions & 4 deletions tests/FSharp.Compiler.ComponentTests/ErrorMessages/SuggestionsTests.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -173,10 +173,8 @@ let r = { Field1 = "hallo"; Field2 = 1 }
"""
|> typecheck
|> shouldFail
|> 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")
]
|> 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"))

[<Fact>]
let ``Suggest Type Parameters`` () =
Expand Down
Loading