opt-in warning attribute not valid for union case with fields (#18532)

Author: edgarfgp

docs/release-notes/.FSharp.Compiler.Service/10.0.100.md

@@ -1,3 +1,6 @@
+### Added
+* Add opt-in warning attribute not valid for union case with fields [PR #18532](https://github.com/dotnet/fsharp/pull/18532))
+
 ### Fixed
 
 * Fix parsing errors using anonymous records and units of measures ([PR #18543](https://github.com/dotnet/fsharp/pull/18543))

src/Compiler/Checking/CheckDeclarations.fs

@@ -576,22 +576,33 @@ module TcRecdUnionAndEnumDeclarations =
 
         let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs
         let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some names)
-        let attrs =
-            (*
-                The attributes of a union case decl get attached to the generated "static factory" method.
-                Enforce union-cases AttributeTargets:
-                - AttributeTargets.Method
-                    type SomeUnion =
-                    | Case1 of int // Compiles down to a static method
-                - AttributeTargets.Property
-                    type SomeUnion =
-                    | Case1 // Compiles down to a static property
-            *)
-            if g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets) then
-                let target = if rfields.IsEmpty then AttributeTargets.Property else AttributeTargets.Method
-                TcAttributes cenv env target synAttrs
-            else
-                TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs
+        let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs
+        (*
+            The attributes of a union case decl get attached to the generated "static factory" method.
+            Enforce union-cases AttributeTargets:
+            - AttributeTargets.Method
+                type SomeUnion =
+                | Case1 of int // Compiles down to a static method
+            - AttributeTargets.Property
+                type SomeUnion =
+                | Case1 // Compiles down to a static property
+        *)
+        if g.langVersion.SupportsFeature(LanguageFeature.EnforceAttributeTargets) then
+            let attrTargets =
+                attrs
+                |> List.collect (fun attr ->
+                    attr.TyconRef.Attribs
+                    |> List.choose (fun attr ->
+                        match attr with
+                        | Attrib(unnamedArgs = [ AttribInt32Arg validOn ]) -> Some validOn
+                        | _ -> None))
+                
+            attrTargets
+            |> List.iter (fun target ->
+                // If the union case has fields, and the target is not AttributeTargets.Method || AttributeTargets.All. Then we raise a separate opt-in warning
+                let hasNotMethodTarget = (enum target &&& AttributeTargets.Method) = enum 0
+                if  hasNotMethodTarget then
+                    warning(Error(FSComp.SR.tcAttributeIsNotValidForUnionCaseWithFields(), id.idRange)))
 
         Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis
 

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -11288,6 +11288,75 @@ and TcNonRecursiveBinding declKind cenv env tpenv ty binding =
     let explicitTyparInfo, tpenv = TcNonrecBindingTyparDecls cenv env tpenv binding
     TcNormalizedBinding declKind cenv env tpenv ty None NoSafeInitInfo ([], explicitTyparInfo) binding
 
+and ResolveAttributeType (cenv: cenv) (env: TcEnv) (mAttr: range) (tycon: Ident list) =
+    let tpenv = emptyUnscopedTyparEnv
+    let ad = env.eAccessRights
+    
+    let tyPath, tyId = List.frontAndBack tycon
+    
+    let try1 n =
+        let tyid = mkSynId tyId.idRange n
+        let tycon = (tyPath @ [tyid])
+
+        match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.UseInAttribute OpenQualified env.eNameResEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with
+        | Exception err -> raze err
+        | Result(tinstEnclosing, tcref, inst) -> success(TcTypeApp cenv NoNewTypars CheckCxs ItemOccurrence.UseInAttribute env tpenv mAttr tcref tinstEnclosing [] inst)
+
+    ForceRaise ((try1 (tyId.idText + "Attribute")) |> otherwise (fun () -> (try1 tyId.idText)))
+
+and CheckAttributeUsage (g: TcGlobals) (mAttr: range) (tcref: TyconRef) (attrTgt: AttributeTargets) (targetIndicator: Ident option) (attrEx: AttributeTargets) =
+    // REVIEW: take notice of inherited?
+    let validOn, _inherited =
+        let validOnDefault = 0x7fff
+        let inheritedDefault = true
+        if tcref.IsILTycon then
+            let tdef = tcref.ILTyconRawMetadata
+            let tref = g.attrib_AttributeUsageAttribute.TypeRef
+
+            match TryDecodeILAttribute tref tdef.CustomAttrs with
+            | Some ([ILAttribElem.Int32 validOn ], named) ->
+                let inherited =
+                    match List.tryPick (function "Inherited", _, _, ILAttribElem.Bool res -> Some res | _ -> None) named with
+                    | None -> inheritedDefault
+                    | Some x -> x
+                (validOn, inherited)
+            | Some ([ILAttribElem.Int32 validOn; ILAttribElem.Bool _allowMultiple; ILAttribElem.Bool inherited ], _) ->
+                (validOn, inherited)
+            | _ ->
+                (validOnDefault, inheritedDefault)
+        else
+            match (TryFindFSharpAttribute g g.attrib_AttributeUsageAttribute tcref.Attribs) with
+            | Some(Attrib(unnamedArgs = [ AttribInt32Arg validOn ])) ->
+                validOn, inheritedDefault
+            | Some(Attrib(unnamedArgs = [ AttribInt32Arg validOn; AttribBoolArg(_allowMultiple); AttribBoolArg inherited])) ->
+                validOn, inherited
+            | Some _ ->
+                warning(Error(FSComp.SR.tcUnexpectedConditionInImportedAssembly(), mAttr))
+                validOnDefault, inheritedDefault
+            | _ ->
+                validOnDefault, inheritedDefault
+    
+    // Determine valid attribute targets
+    let attributeTargets = enum validOn &&& attrTgt
+    let directedTargets =
+        match targetIndicator with
+        | LongFormAttrTarget attrTarget -> attrTarget
+        | UnrecognizedLongAttrTarget attrTarget ->
+            errorR(Error(FSComp.SR.tcUnrecognizedAttributeTarget(), attrTarget.idRange))
+            attributeTargets
+        | ShortFormAttributeTarget -> attributeTargets &&& ~~~ attrEx
+  
+    let constrainedTargets = attributeTargets &&& directedTargets
+
+    // Check if attribute is valid for the target
+    if constrainedTargets = enum 0 then
+        if (directedTargets = AttributeTargets.Assembly || directedTargets = AttributeTargets.Module) then
+            errorR(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElementUseDo(), mAttr))
+        else
+            warning(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(), mAttr))
+    
+    constrainedTargets
+
 //-------------------------------------------------------------------------
 // TcAttribute*
 // *Ex means the function accepts attribute targets that must be explicit
@@ -11302,24 +11371,13 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
     let targetIndicator = synAttr.Target
     let isAppliedToGetterOrSetter = synAttr.AppliesToGetterAndSetter
     let mAttr = synAttr.Range
-    let typath, tyid = List.frontAndBack tycon
-    let tpenv = emptyUnscopedTyparEnv
+    let _, tyId = List.frontAndBack tycon
     let ad = env.eAccessRights
 
     // if we're checking an attribute that was applied directly to a getter or a setter, then
     // what we're really checking against is a method, not a property
     let attrTgt = if isAppliedToGetterOrSetter then ((attrTgt ^^^ AttributeTargets.Property) ||| AttributeTargets.Method) else attrTgt
-    let ty, tpenv =
-        let try1 n =
-            let tyid = mkSynId tyid.idRange n
-            let tycon = (typath @ [tyid])
-
-            match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurrence.UseInAttribute OpenQualified env.eNameResEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with
-            | Exception err -> raze err
-            | Result(tinstEnclosing, tcref, inst) -> success(TcTypeApp cenv NoNewTypars CheckCxs ItemOccurrence.UseInAttribute env tpenv mAttr tcref tinstEnclosing [] inst)
-
-        ForceRaise ((try1 (tyid.idText + "Attribute")) |> otherwise (fun () -> (try1 tyid.idText)))
-
+    let ty, tpenv = ResolveAttributeType cenv env mAttr tycon
     if not (IsTypeAccessible g cenv.amap mAttr ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(), mAttr))
 
     let tcref = tcrefOfAppTy g ty
@@ -11330,53 +11388,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
     | Some d, Some defines when not (List.contains d defines) ->
         [], false
     | _ ->
-         // REVIEW: take notice of inherited?
-        let validOn, _inherited =
-            let validOnDefault = 0x7fff
-            let inheritedDefault = true
-            if tcref.IsILTycon then
-                let tdef = tcref.ILTyconRawMetadata
-                let tref = g.attrib_AttributeUsageAttribute.TypeRef
-
-                match TryDecodeILAttribute tref tdef.CustomAttrs with
-                | Some ([ILAttribElem.Int32 validOn ], named) ->
-                    let inherited =
-                        match List.tryPick (function "Inherited", _, _, ILAttribElem.Bool res -> Some res | _ -> None) named with
-                        | None -> inheritedDefault
-                        | Some x -> x
-                    (validOn, inherited)
-                | Some ([ILAttribElem.Int32 validOn; ILAttribElem.Bool _allowMultiple; ILAttribElem.Bool inherited ], _) ->
-                    (validOn, inherited)
-                | _ ->
-                    (validOnDefault, inheritedDefault)
-            else
-                match (TryFindFSharpAttribute g g.attrib_AttributeUsageAttribute tcref.Attribs) with
-                | Some(Attrib(_, _, [ AttribInt32Arg validOn ], _, _, _, _)) ->
-                    (validOn, inheritedDefault)
-                | Some(Attrib(_, _, [ AttribInt32Arg validOn
-                                      AttribBoolArg(_allowMultiple)
-                                      AttribBoolArg inherited], _, _, _, _)) ->
-                    (validOn, inherited)
-                | Some _ ->
-                    warning(Error(FSComp.SR.tcUnexpectedConditionInImportedAssembly(), mAttr))
-                    (validOnDefault, inheritedDefault)
-                | _ ->
-                    (validOnDefault, inheritedDefault)
-        let attributeTargets = enum validOn &&& attrTgt
-        let directedTargets =
-            match targetIndicator with
-            | LongFormAttrTarget attrTarget -> attrTarget
-            | UnrecognizedLongAttrTarget attrTarget ->
-                errorR(Error(FSComp.SR.tcUnrecognizedAttributeTarget(), attrTarget.idRange))
-                attributeTargets
-            | ShortFormAttributeTarget -> attributeTargets &&& ~~~ attrEx
-      
-        let constrainedTargets = attributeTargets &&& directedTargets
-        if constrainedTargets = enum 0 then
-            if (directedTargets = AttributeTargets.Assembly || directedTargets = AttributeTargets.Module) then
-                error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElementUseDo(), mAttr))
-            else
-                warning(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(), mAttr))
+        let constrainedTargets = CheckAttributeUsage g mAttr tcref attrTgt targetIndicator attrEx
 
         match ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty with
         | Exception _ when canFail = TcCanFail.IgnoreAllErrors || canFail = TcCanFail.IgnoreMemberResoutionError -> [ ], true
@@ -11391,7 +11403,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
             match item with
             | Item.CtorGroup(methodName, minfos) ->
                 let meths = minfos |> List.map (fun minfo -> minfo, None)
-                let afterResolution = ForNewConstructors cenv.tcSink env tyid.idRange methodName minfos
+                let afterResolution = ForNewConstructors cenv.tcSink env tyId.idRange methodName minfos
                 let (expr, attributeAssignedNamedItems, _), _ =
                   TcMethodApplication true cenv env tpenv None [] mAttr mAttr methodName None ad PossiblyMutates false meths afterResolution NormalValUse [arg] (MustEqual ty) None []
 

src/Compiler/Checking/Expressions/CheckExpressions.fsi

@@ -955,6 +955,8 @@ module AttributeTargets =
     val FieldDeclRestricted: AttributeTargets
 
     /// The allowed attribute targets for an F# union case declaration
+    /// - AttributeTargets.Method: union case with fields
+    /// - AttributeTargets.Property: union case with no fields
     val UnionCaseDecl: AttributeTargets
 
     /// The allowed attribute targets for an F# type declaration

src/Compiler/Driver/CompilerDiagnostics.fs

@@ -402,6 +402,7 @@ type PhasedDiagnostic with
         | 3579 -> false // alwaysUseTypedStringInterpolation - off by default
         | 3582 -> false // infoIfFunctionShadowsUnionCase - off by default
         | 3570 -> false // tcAmbiguousDiscardDotLambda - off by default
+        | 3878 -> false // tcAttributeIsNotValidForUnionCaseWithFields - off by default
         | _ ->
             match x.Exception with
             | DiagnosticEnabledWithLanguageFeature(_, _, _, enabled) -> enabled

src/Compiler/FSComp.txt

@@ -1806,4 +1806,5 @@ featureAllowLetOrUseBangTypeAnnotationWithoutParens,"Allow let! and use! type an
 3874,lexWarnDirectiveMustBeFirst,"#nowarn/#warnon directives must appear as the first non-whitespace characters on a line"
 3875,lexWarnDirectiveMustHaveArgs,"Warn directives must have warning number(s) as argument(s)"
 3876,lexWarnDirectivesMustMatch,"There is another %s for this warning already in line %d."
-3877,lexLineDirectiveMappingIsNotUnique,"The file '%s' was also pointed to in a line directive in '%s'. Proper warn directive application may not be possible."
+3877,lexLineDirectiveMappingIsNotUnique,"The file '%s' was also pointed to in a line directive in '%s'. Proper warn directive application may not be possible."
+3878,tcAttributeIsNotValidForUnionCaseWithFields,"This attribute is not valid for use on union cases with fields."