diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 9ddff1e7585..ef8ecf003f2 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -500,22 +500,20 @@ module TcRecdUnionAndEnumDeclarations = if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then errorR(NotUpperCaseConstructor(id.idRange)) - let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) = + let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) = let seen = Dictionary() (synFields, tastFields) ||> List.iter2 (fun sf f -> match seen.TryGetValue f.LogicalName with | true, synField -> match sf, synField with - | SynField(idOpt = Some id), SynField(idOpt = Some _) -> - error(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(id.idText), id.idRange)) | SynField(idOpt = Some id), SynField(idOpt = None) | SynField(idOpt = None), SynField(idOpt = Some id) -> error(Error(FSComp.SR.tcFieldNameConflictsWithGeneratedNameForAnonymousField(id.idText), id.idRange)) - | _ -> assert false + | _ -> () | _ -> seen.Add(f.LogicalName, sf)) - let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv hasRQAAttribute (SynUnionCase(Attributes synAttrs, SynIdent(id, _), args, xmldoc, vis, m, _)) = + let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv hasRQAAttribute (SynUnionCase(Attributes synAttrs, SynIdent(ident= id), args, xmldoc, vis, m, _)) = let g = cenv.g let vis, _ = ComputeAccessAndCompPath g env None m vis None parent let vis = CombineReprAccess parent vis @@ -588,11 +586,26 @@ module TcRecdUnionAndEnumDeclarations = Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis + let CheckUnionDuplicateFields (elems: Ident list) = + elems |> List.iteri (fun i (uc1: Ident) -> + elems |> List.iteri (fun j (uc2: Ident) -> + if j > i && uc1.idText = uc2.idText then + errorR(Error(FSComp.SR.tcFieldNameIsUsedModeThanOnce(uc1.idText), uc1.idRange)))) + let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) hasRQAAttribute tpenv unionCases = let unionCasesR = unionCases - |> List.filter (fun (SynUnionCase(_, SynIdent(id, _), _, _, _, _, _)) -> id.idText <> "") - |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv hasRQAAttribute) + |> List.choose(fun syn -> + match syn with + | SynUnionCase(ident= SynIdent(ident = id)) as syn when id.idText <> "" -> + Some (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv hasRQAAttribute syn) + | _ -> None) + + for uc in unionCasesR do + let fields = uc.FieldTable.TrueInstanceFieldsAsList |> List.map (fun f -> f.Id) + if fields.Length > 1 then + CheckUnionDuplicateFields fields + unionCasesR |> CheckDuplicates (fun uc -> uc.Id) "union case" let MakeEnumCaseSpec g cenv env parent attrs thisTy caseRange (caseIdent: Ident) (xmldoc: PreXmlDoc) value = diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs index 4611fef33ea..53ca58b15ca 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Types/UnionTypes/UnionTypes.fs @@ -273,7 +273,7 @@ module UnionTypes = |> shouldFail |> withDiagnostics [ (Error 3176, Line 7, Col 16, Line 7, Col 21, "Named field 'Item2' conflicts with autogenerated name for anonymous field.") - (Error 3176, Line 10, Col 26, Line 10, Col 27, "Named field 'A' is used more than once.") + (Error 3176, Line 10, Col 16, Line 10, Col 17, "Named field 'A' is used more than once.") ] //SOURCE=E_UnionFieldNamedTag.fs SCFLAGS="--test:ErrorRanges" # E_UnionFieldNamedTag.fs @@ -610,6 +610,64 @@ module UnionTypes = |> withDiagnostics [ (Warning 42, Line 11, Col 12, Line 11, Col 24, "This construct is deprecated: it is only for use in the F# library") ] + + + [] + let ``Union field appears multiple times in union declaration`` () = + Fsx """ +type X = + | A of a: int * a: int + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 3176, Line 3, Col 12, Line 3, Col 13, "Named field 'a' is used more than once.") + ] + + [] + let ``Union field appears multiple times in union declaration 2`` () = + Fsx """ +type X = + | A of a: int * a: int + | B of a: int * a: int + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 3176, Line 3, Col 12, Line 3, Col 13, "Named field 'a' is used more than once.") + (Error 3176, Line 4, Col 12, Line 4, Col 13, "Named field 'a' is used more than once.") + ] + + [] + let ``Union field appears multiple times in union declaration 3`` () = + Fsx """ +type X = + | A of a: int * a: int * a: int + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 3176, Line 3, Col 12, Line 3, Col 13, "Named field 'a' is used more than once.") + (Error 3176, Line 3, Col 21, Line 3, Col 22, "Named field 'a' is used more than once.") + ] + + [] + let ``Union field appears multiple times in union declaration 4`` () = + Fsx """ +type X = + | A of a: int * a: int + +let x = A (1, 2) + +match x with +| A(a = 1) -> () +| _ -> () + """ + |> typecheck + |> shouldFail + |> withDiagnostics [ + (Error 3176, Line 3, Col 12, Line 3, Col 13, "Named field 'a' is used more than once.") + ] [] []