diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs
index 59054ddb047b..2712972de631 100644
--- a/src/Compiler/Checking/CheckDeclarations.fs
+++ b/src/Compiler/Checking/CheckDeclarations.fs
@@ -452,7 +452,7 @@ module TcRecdUnionAndEnumDeclarations =
// Bind other elements of type definitions (constructors etc.)
//-------------------------------------------------------------------------
- let CheckUnionCaseName (cenv: cenv) (id: Ident) =
+ let CheckUnionCaseName (cenv: cenv) (id: Ident) hasRQAAttribute =
let g = cenv.g
let name = id.idText
if name = "Tags" then
@@ -460,7 +460,7 @@ module TcRecdUnionAndEnumDeclarations =
CheckNamespaceModuleOrTypeName g id
- if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then
+ if not (String.isLeadingIdentifierCharacterUpperCase name) && not hasRQAAttribute && name <> opNameCons && name <> opNameNil then
errorR(NotUpperCaseConstructor(id.idRange))
let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) =
@@ -478,16 +478,13 @@ module TcRecdUnionAndEnumDeclarations =
| _ ->
seen.Add(f.LogicalName, sf))
- let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv (tycon: Tycon) (SynUnionCase(Attributes synAttrs, SynIdent(id, _), args, xmldoc, vis, m, _)) =
+ let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv hasRQAAttribute (SynUnionCase(Attributes synAttrs, SynIdent(id, _), args, xmldoc, vis, m, _)) =
let g = cenv.g
let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs // the attributes of a union case decl get attached to the generated "static factory" method
let vis, _ = ComputeAccessAndCompPath env None m vis None parent
let vis = CombineReprAccess parent vis
- let hasRequireQualifiedAccessAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
-
- if not hasRequireQualifiedAccessAttribute then
- CheckUnionCaseName cenv id
+ CheckUnionCaseName cenv id hasRQAAttribute
let rfields, recordTy =
match args with
@@ -528,8 +525,8 @@ module TcRecdUnionAndEnumDeclarations =
let xmlDoc = xmldoc.ToXmlDoc(true, Some names)
Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis
- let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) (tycon: Tycon) tpenv unionCases =
- let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv tycon)
+ let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) hasRQAAttribute tpenv unionCases =
+ let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv hasRQAAttribute)
unionCasesR |> CheckDuplicates (fun uc -> uc.Id) "union case"
let TcEnumDecl cenv env parent thisTy fieldTy (SynEnumCase(attributes=Attributes synAttrs; ident= SynIdent(id,_); value=v; xmlDoc=xmldoc; range=m)) =
@@ -4056,9 +4053,8 @@ module EstablishTypeDefinitionCores =
structLayoutAttributeCheck false
noAllowNullLiteralAttributeCheck()
- let hasRequireQualifiedAccessAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
- if not hasRequireQualifiedAccessAttribute then
- TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName
+ let hasRQAAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
+ TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName hasRQAAttribute
let unionCase = Construct.NewUnionCase unionCaseName [] thisTy [] XmlDoc.Empty tycon.Accessibility
writeFakeUnionCtorsToSink [ unionCase ]
Construct.MakeUnionRepr [ unionCase ], None, NoSafeInitInfo
@@ -4090,7 +4086,8 @@ module EstablishTypeDefinitionCores =
noAllowNullLiteralAttributeCheck()
structLayoutAttributeCheck false
- let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst tycon tpenv unionCases
+ let hasRQAAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
+ let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst hasRQAAttribute tpenv unionCases
if tycon.IsStructRecordOrUnionTycon && unionCases.Length > 1 then
let fieldNames = [ for uc in unionCases do for ft in uc.FieldTable.TrueInstanceFieldsAsList do yield ft.LogicalName ]
if fieldNames |> List.distinct |> List.length <> fieldNames.Length then
diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/E_LowercaseWhenRequireQualifiedAccess.fsx b/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/E_LowercaseWhenRequireQualifiedAccess.fsx
new file mode 100644
index 000000000000..19ad8f3670d1
--- /dev/null
+++ b/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/E_LowercaseWhenRequireQualifiedAccess.fsx
@@ -0,0 +1,22 @@
+// #Conformance #TypesAndModules #Unions
+// This testcase verifies that lower-case discriminated union are not allowed
+//
+#light
+
+type DU1 = | ``not.allowed``
+
+type DU2 = ``not.allowed``
+
+[]
+type DU3 = | ``not.allowed``
+
+[]
+type DU4 = ``not.allowed``
+
+type DU5 = | a
+
+type DU6 = a
+
+type du1 = du1 of string
+
+type du2 = | du2 of string
\ No newline at end of file
diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/UnionTypes.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/UnionTypes.fs
index e1f7e8b6d2f5..46c38e6ef518 100644
--- a/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/UnionTypes.fs
+++ b/tests/FSharp.Compiler.ComponentTests/Conformance/UnionTypes/UnionTypes.fs
@@ -516,6 +516,25 @@ module UnionTypes =
|> verifyCompileAndRun
|> shouldSucceed
+ //SOURCE=E_LowercaseWhenRequireQualifiedAccess.fsx # E_LowercaseWhenRequireQualifiedAccess.fsx
+ []
+ let ``E_LowercaseWhenRequireQualifiedAccess_fs`` compilation =
+ compilation
+ |> verifyCompile
+ |> shouldFail
+ |> withDiagnostics [
+ (Error 883, Line 6, Col 14, Line 6, Col 29, "Invalid namespace, module, type or union case name");
+ (Error 53, Line 6, Col 14, Line 6, Col 29, "Discriminated union cases and exception labels must be uppercase identifiers");
+ (Error 883, Line 8, Col 12, Line 8, Col 27, "Invalid namespace, module, type or union case name");
+ (Error 53, Line 8, Col 12, Line 8, Col 27, "Discriminated union cases and exception labels must be uppercase identifiers");
+ (Error 883, Line 11, Col 14, Line 11, Col 29, "Invalid namespace, module, type or union case name");
+ (Error 883, Line 14, Col 12, Line 14, Col 27, "Invalid namespace, module, type or union case name");
+ (Error 53, Line 16, Col 14, Line 16, Col 15, "Discriminated union cases and exception labels must be uppercase identifiers");
+ (Error 53, Line 18, Col 12, Line 18, Col 13, "Discriminated union cases and exception labels must be uppercase identifiers");
+ (Error 53, Line 20, Col 12, Line 20, Col 15, "Discriminated union cases and exception labels must be uppercase identifiers");
+ (Error 53, Line 22, Col 14, Line 22, Col 17, "Discriminated union cases and exception labels must be uppercase identifiers")
+ ]
+
//SOURCE=W_GenericFunctionValuedStaticProp02.fs SCFLAGS="--test:ErrorRanges --warnaserror-" # W_GenericFunctionValuedStaticProp02.fs
[]
let ``W_GenericFunctionValuedStaticProp02_fs`` compilation =