Allow lower-case DU cases when RequireQualifiedAccess is specified (#13432)

* Allow lower-case DU cases when RequireQualifiedAccess is specified

* Fix PR suggestions and Add more testing

* Protect feature under preview version

* Add a NotUpperCaseConstructorWithoutRQA warning to be raised in lang version preview

* Fix formatting

Author: edgarfgp

src/Compiler/Checking/CheckDeclarations.fs

@@ -378,6 +378,8 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath (env:
 
 exception NotUpperCaseConstructor of range: range
 
+exception NotUpperCaseConstructorWithoutRQA of range: range
+
 let CheckNamespaceModuleOrTypeName (g: TcGlobals) (id: Ident) = 
     // type names '[]' etc. are used in fslib
     if not g.compilingFSharpCore && id.idText.IndexOfAny IllegalCharactersInTypeAndNamespaceNames <> -1 then 
@@ -453,16 +455,21 @@ 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
             errorR(Error(FSComp.SR.tcUnionCaseNameConflictsWithGeneratedType(name, "Tags"), id.idRange))
 
         CheckNamespaceModuleOrTypeName g id
 
-        if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then
-            errorR(NotUpperCaseConstructor(id.idRange))
+        if g.langVersion.SupportsFeature(LanguageFeature.LowercaseDUWhenRequireQualifiedAccess) then
+
+            if not (String.isLeadingIdentifierCharacterUpperCase name) && not hasRQAAttribute && name <> opNameCons && name <> opNameNil then
+                errorR(NotUpperCaseConstructorWithoutRQA(id.idRange))
+        else
+            if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then
+                errorR(NotUpperCaseConstructor(id.idRange))
 
     let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) = 
         let seen = Dictionary()
@@ -479,13 +486,13 @@ module TcRecdUnionAndEnumDeclarations =
             | _ ->
                 seen.Add(f.LogicalName, sf))
 
-    let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv (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
 
-        CheckUnionCaseName cenv id
+        CheckUnionCaseName cenv id hasRQAAttribute
 
         let rfields, recordTy = 
             match args with
@@ -526,8 +533,8 @@ module TcRecdUnionAndEnumDeclarations =
         let xmlDoc = xmldoc.ToXmlDoc(true, Some names)
         Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis
 
-    let TcUnionCaseDecls cenv env parent (thisTy: TType) thisTyInst tpenv unionCases =
-        let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv) 
+    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)) =
@@ -3188,7 +3195,9 @@ module EstablishTypeDefinitionCores =
 
                     structLayoutAttributeCheck false
                     noAllowNullLiteralAttributeCheck()
-                    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
@@ -3219,8 +3228,9 @@ module EstablishTypeDefinitionCores =
                     noAbstractClassAttributeCheck()
                     noAllowNullLiteralAttributeCheck()
                     structLayoutAttributeCheck false
-                    let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst 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 

src/Compiler/Checking/CheckDeclarations.fsi

@@ -76,3 +76,5 @@ val CheckOneSigFile:
             Cancellable<TcEnv * ModuleOrNamespaceType * bool>
 
 exception NotUpperCaseConstructor of range: range
+
+exception NotUpperCaseConstructorWithoutRQA of range: range

src/Compiler/Driver/CompilerDiagnostics.fs

@@ -124,6 +124,7 @@ let GetRangeOfDiagnostic (diagnostic: PhasedDiagnostic) =
         | LetRecCheckedAtRuntime m
         | UpperCaseIdentifierInPattern m
         | NotUpperCaseConstructor m
+        | NotUpperCaseConstructorWithoutRQA m
         | RecursiveUseCheckedAtRuntime (_, _, m)
         | LetRecEvaluatedOutOfOrder (_, _, _, m)
         | DiagnosticWithText (_, _, m)
@@ -270,6 +271,7 @@ let GetDiagnosticNumber (diagnostic: PhasedDiagnostic) =
         | UseOfAddressOfOperator _ -> 51
         | DefensiveCopyWarning _ -> 52
         | NotUpperCaseConstructor _ -> 53
+        | NotUpperCaseConstructorWithoutRQA _ -> 53
         | TypeIsImplicitlyAbstract _ -> 54
         // 55 cannot be reused
         | DeprecatedThreadStaticBindingWarning _ -> 56
@@ -435,6 +437,7 @@ let ErrorFromApplyingDefault2E () = Message("ErrorFromApplyingDefault2", "")
 let ErrorsFromAddingSubsumptionConstraintE () = Message("ErrorsFromAddingSubsumptionConstraint", "%s%s%s")
 let UpperCaseIdentifierInPatternE () = Message("UpperCaseIdentifierInPattern", "")
 let NotUpperCaseConstructorE () = Message("NotUpperCaseConstructor", "")
+let NotUpperCaseConstructorWithoutRQAE () = Message("NotUpperCaseConstructorWithoutRQA", "")
 let FunctionExpectedE () = Message("FunctionExpected", "")
 let BakedInMemberConstraintNameE () = Message("BakedInMemberConstraintName", "%s")
 let BadEventTransformationE () = Message("BadEventTransformation", "")
@@ -771,6 +774,8 @@ let OutputPhasedErrorR (os: StringBuilder) (diagnostic: PhasedDiagnostic) (canSu
 
         | NotUpperCaseConstructor _ -> os.AppendString(NotUpperCaseConstructorE().Format)
 
+        | NotUpperCaseConstructorWithoutRQA _ -> os.AppendString(NotUpperCaseConstructorWithoutRQAE().Format)
+
         | ErrorFromAddingConstraint (_, e, _) -> OutputExceptionR os e
 
 #if !NO_TYPEPROVIDERS

src/Compiler/FSComp.txt

@@ -1543,6 +1543,7 @@ featureStructActivePattern,"struct representation for active patterns"
 featureRelaxWhitespace2,"whitespace relaxation v2"
 featureReallyLongList,"list literals of any size"
 featureErrorOnDeprecatedRequireQualifiedAccess,"give error on deprecated access of construct with RequireQualifiedAccess attribute"
+featureLowercaseDUWhenRequireQualifiedAccess,"Allow lowercase DU when RequireQualifiedAccess attribute"
 3353,fsiInvalidDirective,"Invalid directive '#%s %s'"
 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation."
 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation."

src/Compiler/FSStrings.resx

@@ -1107,4 +1107,7 @@
   <data name="TargetInvocationExceptionWrapper" xml:space="preserve">
     <value>internal error: {0}</value>
   </data>
+  <data name="NotUpperCaseConstructorWithoutRQA" xml:space="preserve">
+    <value>Lowercase discriminated union cases are only allowed when using RequireQualifiedAccess attribute</value>
+  </data>
 </root>

src/Compiler/Facilities/LanguageFeatures.fs

@@ -49,6 +49,7 @@ type LanguageFeature =
     | DelegateTypeNameResolutionFix
     | ReallyLongLists
     | ErrorOnDeprecatedRequireQualifiedAccess
+    | LowercaseDUWhenRequireQualifiedAccess
 
 /// LanguageVersion management
 type LanguageVersion(versionText) =
@@ -111,6 +112,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.BetterExceptionPrinting, previewVersion
                 LanguageFeature.ReallyLongLists, previewVersion
                 LanguageFeature.ErrorOnDeprecatedRequireQualifiedAccess, previewVersion
+                LanguageFeature.LowercaseDUWhenRequireQualifiedAccess, previewVersion
             ]
 
     static let defaultLanguageVersion = LanguageVersion("default")
@@ -210,6 +212,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.DelegateTypeNameResolutionFix -> FSComp.SR.featureDelegateTypeNameResolutionFix ()
         | LanguageFeature.ReallyLongLists -> FSComp.SR.featureReallyLongList ()
         | LanguageFeature.ErrorOnDeprecatedRequireQualifiedAccess -> FSComp.SR.featureErrorOnDeprecatedRequireQualifiedAccess ()
+        | LanguageFeature.LowercaseDUWhenRequireQualifiedAccess -> FSComp.SR.featureLowercaseDUWhenRequireQualifiedAccess ()
 
     /// Get a version string associated with the given feature.
     member _.GetFeatureVersionString feature =

src/Compiler/Facilities/LanguageFeatures.fsi

@@ -39,6 +39,7 @@ type LanguageFeature =
     | DelegateTypeNameResolutionFix
     | ReallyLongLists
     | ErrorOnDeprecatedRequireQualifiedAccess
+    | LowercaseDUWhenRequireQualifiedAccess
 
 /// LanguageVersion management
 type LanguageVersion =

src/Compiler/xlf/FSComp.txt.cs.xlf

@@ -192,6 +192,11 @@
         <target state="translated">rozhraní s vícenásobným obecným vytvářením instancí</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureLowercaseDUWhenRequireQualifiedAccess">
+        <source>Allow lowercase DU when RequireQualifiedAccess attribute</source>
+        <target state="new">Allow lowercase DU when RequireQualifiedAccess attribute</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureMLCompatRevisions">
         <source>ML compatibility revisions</source>
         <target state="translated">Revize kompatibility ML</target>

src/Compiler/xlf/FSComp.txt.de.xlf

@@ -192,6 +192,11 @@
         <target state="translated">Schnittstellen mit mehrfacher generischer Instanziierung</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureLowercaseDUWhenRequireQualifiedAccess">
+        <source>Allow lowercase DU when RequireQualifiedAccess attribute</source>
+        <target state="new">Allow lowercase DU when RequireQualifiedAccess attribute</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureMLCompatRevisions">
         <source>ML compatibility revisions</source>
         <target state="translated">ML-Kompatibilitätsrevisionen</target>

src/Compiler/xlf/FSComp.txt.es.xlf

@@ -192,6 +192,11 @@
         <target state="translated">interfaces con creación de instancias genéricas múltiples</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureLowercaseDUWhenRequireQualifiedAccess">
+        <source>Allow lowercase DU when RequireQualifiedAccess attribute</source>
+        <target state="new">Allow lowercase DU when RequireQualifiedAccess attribute</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureMLCompatRevisions">
         <source>ML compatibility revisions</source>
         <target state="translated">Revisiones de compatibilidad de ML</target>