Allow generic attributes

src/Compiler/Checking/CheckExpressions.fs

@@ -903,11 +903,18 @@ let TranslateTopArgSynInfo isArg m tcAttributes (SynArgInfo(Attributes attrs, is
     // Synthesize an artificial "OptionalArgument" attribute for the parameter
     let optAttrs =
         if isOpt then
-            [ ( { TypeName=SynLongIdent(pathToSynLid m ["Microsoft";"FSharp";"Core";"OptionalArgument"], [], [None;None;None;None])
-                  ArgExpr=mkSynUnit m
-                  Target=None
-                  AppliesToGetterAndSetter=false
-                  Range=m} : SynAttribute) ]
+            [
+             ({ TypeName = SynLongIdent(pathToSynLid m [ "Microsoft"; "FSharp"; "Core"; "OptionalArgument" ], [], [ None; None; None; None ])
+                ArgExpr = mkSynUnit m
+                Target = None
+                AppliesToGetterAndSetter = false
+                Range = m
+                LessRange = None
+                TypeArgs = []
+                CommaRanges = []
+                GreaterRange = None
+                } : SynAttribute)
+            ]
          else
             []
 
@@ -10530,13 +10537,16 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
             let ad = env.eAccessRights
             match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInAttribute OpenQualified env.eNameResEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with
             | Exception err -> raze err
-            | _ -> success(TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInAttribute WarnOnIWSAM.Yes env tpenv (SynType.App(SynType.LongIdent(SynLongIdent(tycon, [], List.replicate tycon.Length None)), None, [], [], None, false, mAttr)) )
+            | _ -> success(TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInAttribute WarnOnIWSAM.Yes env tpenv (SynType.App(SynType.LongIdent(SynLongIdent(tycon, [], List.replicate tycon.Length None)), synAttr.LessRange, synAttr.TypeArgs, synAttr.CommaRanges, synAttr.GreaterRange, false, mAttr)) )
         ForceRaise ((try1 (tyid.idText + "Attribute")) |> otherwise (fun () -> (try1 tyid.idText)))
 
     let ad = env.eAccessRights
 
     if not (IsTypeAccessible g cenv.amap mAttr ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(), mAttr))
 
+    if typeContainsTypars g ty then
+        errorR(Error(FSComp.SR.tcAttributeTypeArgumentUsesTypeParameters(), mAttr))
+
     let tcref = tcrefOfAppTy g ty
 
     let conditionalCallDefineOpt = TryFindTyconRefStringAttribute g mAttr g.attrib_ConditionalAttribute tcref
@@ -10608,7 +10618,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
 
         let item = ForceRaise res
 
-        if not (ExistsHeadTypeInEntireHierarchy g cenv.amap mAttr ty g.tcref_System_Attribute) then
+        if not (ExistsHeadTypeInEntireHierarchy g cenv.amap mAttr ty g.tcref_System_Attribute) && not (isObjTy g ty) then
             warning(Error(FSComp.SR.tcTypeDoesNotInheritAttribute(), mAttr))
 
         let attrib =

src/Compiler/FSComp.txt

@@ -1563,6 +1563,7 @@ featureArithmeticInLiterals,"Allow arithmetic and logical operations in literals
 featureErrorReportingOnStaticClasses,"Error reporting on static classes"
 featureTryWithInSeqExpressions,"Support for try-with in sequence expressions"
 featureWarningWhenCopyAndUpdateRecordChangesAllFields,"Raises warnings when an copy-and-update record expression changes all fields of a record."
+featureGenericAttributes,"Allow generic attributes"
 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."
@@ -1677,3 +1678,4 @@ featureEscapeBracesInFormattableString,"Escapes curly braces before calling Form
 3558,chkExplicitFieldsDeclarationsOnStaticClasses,"If a type uses both [<Sealed>] and [<AbstractClass>] attributes, it means it is static. Explicit field declarations are not allowed."
 3559,typrelNeverRefinedAwayFromTop,"A type has been implicitly inferred as 'obj', which may be unintended. Consider adding explicit type annotations. You can disable this warning by using '#nowarn \"3559\"' or '--nowarn:3559'."
 3560,tcCopyAndUpdateRecordChangesAllFields,"This copy-and-update record expression changes all fields of record type '%s'. Consider using the record construction syntax instead."
+3561,tcAttributeTypeArgumentUsesTypeParameters,"An attribute type argument cannot use type parameters."

src/Compiler/Facilities/LanguageFeatures.fs

@@ -63,6 +63,7 @@ type LanguageFeature =
     | ErrorReportingOnStaticClasses
     | TryWithInSeqExpression
     | WarningWhenCopyAndUpdateRecordChangesAllFields
+    | GenericAttributes
 
 /// LanguageVersion management
 type LanguageVersion(versionText) =
@@ -142,6 +143,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.ErrorReportingOnStaticClasses, previewVersion
                 LanguageFeature.TryWithInSeqExpression, previewVersion
                 LanguageFeature.WarningWhenCopyAndUpdateRecordChangesAllFields, previewVersion
+                LanguageFeature.GenericAttributes, previewVersion
 
             ]
 
@@ -258,6 +260,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.ErrorReportingOnStaticClasses -> FSComp.SR.featureErrorReportingOnStaticClasses ()
         | LanguageFeature.TryWithInSeqExpression -> FSComp.SR.featureTryWithInSeqExpressions ()
         | LanguageFeature.WarningWhenCopyAndUpdateRecordChangesAllFields -> FSComp.SR.featureWarningWhenCopyAndUpdateRecordChangesAllFields ()
+        | LanguageFeature.GenericAttributes -> FSComp.SR.featureGenericAttributes ()
 
     /// Get a version string associated with the given feature.
     static member GetFeatureVersionString feature =

src/Compiler/Facilities/LanguageFeatures.fsi

@@ -53,6 +53,7 @@ type LanguageFeature =
     | ErrorReportingOnStaticClasses
     | TryWithInSeqExpression
     | WarningWhenCopyAndUpdateRecordChangesAllFields
+    | GenericAttributes
 
 /// LanguageVersion management
 type LanguageVersion =

src/Compiler/SyntaxTree/ParseHelpers.fs

@@ -1084,3 +1084,37 @@ let appendValToLeadingKeyword mVal leadingKeyword =
     | SynLeadingKeyword.Override mOverride -> SynLeadingKeyword.OverrideVal(mOverride, mVal)
     | SynLeadingKeyword.Default (mDefault) -> SynLeadingKeyword.DefaultVal(mDefault, mVal)
     | _ -> leadingKeyword
+
+let mkAttribute langVersion target (typeName: SynLongIdent) typeArgs argExpr =
+    let arg =
+        match argExpr with
+        | None -> mkSynUnit typeName.Range
+        | Some e -> e
+
+    let startRange =
+        match target with
+        | Some (ident: Ident) -> ident.idRange
+        | None -> typeName.Range
+
+    let lessRange, typeArgs, commaRanges, greaterRange, mTypeArgsRange =
+        match typeArgs with
+        | Some (lessRange, greaterRange, _: bool, typeArgs, commaRanges, mTypeArgsRange) ->
+            Some lessRange, typeArgs, commaRanges, greaterRange, Some mTypeArgsRange
+        | None -> None, [], [], None, None
+
+    let m = unionRanges startRange (Option.defaultValue arg.Range mTypeArgsRange)
+
+    if not typeArgs.IsEmpty then
+        checkLanguageFeatureAndRecover langVersion LanguageFeature.GenericAttributes m
+
+    {
+        TypeName = typeName
+        ArgExpr = arg
+        Target = target
+        AppliesToGetterAndSetter = false
+        Range = m
+        LessRange = lessRange
+        TypeArgs = typeArgs
+        CommaRanges = commaRanges
+        GreaterRange = greaterRange
+    }: SynAttribute

src/Compiler/SyntaxTree/ParseHelpers.fsi

@@ -236,3 +236,11 @@ val checkForMultipleAugmentations: m: range -> a1: 'a list -> a2: 'a list -> 'a
 val rangeOfLongIdent: lid: LongIdent -> range
 
 val appendValToLeadingKeyword: mVal: range -> leadingKeyword: SynLeadingKeyword -> SynLeadingKeyword
+
+val mkAttribute:
+    langVersion: LanguageVersion ->
+    target: Ident option ->
+    typeName: SynLongIdent ->
+    typeArgs: (range * range option * bool * SynType list * range list * range) option ->
+    argExpr: SynExpr option ->
+        SynAttribute

src/Compiler/SyntaxTree/SyntaxTree.fs

@@ -1015,6 +1015,14 @@ type SynAttribute =
         AppliesToGetterAndSetter: bool
 
         Range: range
+
+        LessRange: range option
+
+        TypeArgs: SynType list
+
+        CommaRanges: range list
+
+        GreaterRange: range option
     }
 
 [<RequireQualifiedAccess>]

src/Compiler/SyntaxTree/SyntaxTree.fsi

@@ -1154,6 +1154,18 @@ type SynAttribute =
 
         /// The syntax range of the attribute
         Range: range
+
+        /// The syntax range of the LESS symbol
+        LessRange: range option
+
+        /// Type arguments
+        TypeArgs: SynType list
+
+        /// Ranges of the commas between type arguments
+        CommaRanges: range list
+
+        /// The syntax range of the GREATER symbol
+        GreaterRange: range option
     }
 
 /// List of attributes enclosed in [< ... >].

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -873,6 +873,18 @@ let (|RefTupleTy|_|) g ty = ty |> stripTyEqns g |> (function TType_tuple(tupInfo
 
 let (|FunTy|_|) g ty = ty |> stripTyEqns g |> (function TType_fun(domainTy, rangeTy, _) -> Some (domainTy, rangeTy) | _ -> None)
 
+let rec typeContainsTypars g ty =
+    match stripTyEqns g ty with
+    | TType_forall _
+    | TType_var _
+    | TType_measure (Measure.Var _) -> true
+    | TType_app (_, tys, _)
+    | TType_tuple (_, tys)
+    | TType_ucase (_, tys)
+    | TType_anon (_, tys) -> tys |> List.exists (typeContainsTypars g)
+    | TType_fun (domainTy, rangeTy, _) -> typeContainsTypars g domainTy && typeContainsTypars g rangeTy
+    | TType_measure _ -> false
+
 let tryNiceEntityRefOfTy ty = 
     let ty = stripTyparEqnsAux false ty 
     match ty with

src/Compiler/TypedTree/TypedTreeOps.fsi

@@ -716,6 +716,8 @@ val tryDestAnyTupleTy: TcGlobals -> TType -> TupInfo * TType list
 
 val tryDestRefTupleTy: TcGlobals -> TType -> TType list
 
+val typeContainsTypars: TcGlobals -> TType -> bool
+
 //-------------------------------------------------------------------------
 // Compute actual types of union cases and fields given an instantiation
 // of the generic type parameters of the enclosing type.

src/Compiler/pars.fsy

@@ -1423,25 +1423,16 @@ attributeListElements:
 /* One custom attribute */
 attribute:
   /* A custom attribute */
-  | path opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
-     { let arg = match $3 with None -> mkSynUnit $1.Range | Some e -> e
-       let m = unionRanges  $1.Range arg.Range
-       ({ TypeName=$1; ArgExpr=arg; Target=None; AppliesToGetterAndSetter=false; Range=m } : SynAttribute) }
+  | path opt_attributeTyApp opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
+     { mkAttribute parseState.LexBuffer.LanguageVersion None $1 $2 $4 }
 
   /* A custom attribute with an attribute target */
-  | attributeTarget path opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
-     { let arg = match $4 with None -> mkSynUnit $2.Range | Some e -> e
-       let startRange = match $1 with Some (ident:Ident) -> ident.idRange | None -> $2.Range
-       let m = unionRanges startRange arg.Range
-       ({ TypeName=$2; ArgExpr=arg; Target=$1; AppliesToGetterAndSetter=false; Range=m } : SynAttribute) }
+  | attributeTarget path opt_attributeTyApp opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
+     { mkAttribute parseState.LexBuffer.LanguageVersion $1 $2 $3 $5 } 
 
   /* A custom attribute with an attribute target */
-  | attributeTarget OBLOCKBEGIN path oblockend opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
-     { let arg = match $6 with None -> mkSynUnit $3.Range | Some e -> e 
-       let startRange = match $1 with Some ident -> ident.idRange | None -> $3.Range
-       let m = unionRanges startRange arg.Range
-       ({ TypeName=$3; ArgExpr=arg; Target=$1; AppliesToGetterAndSetter=false; Range=m } : SynAttribute) }
-
+  | attributeTarget OBLOCKBEGIN path opt_attributeTyApp oblockend opt_HIGH_PRECEDENCE_APP opt_atomicExprAfterType 
+     { mkAttribute parseState.LexBuffer.LanguageVersion $1 $3 $4 $7 }
 
 /* The target of a custom attribute */
 attributeTarget: 
@@ -1458,6 +1449,13 @@ attributeTarget:
       { if $1 then reportParseErrorAt (rhs parseState 1) (FSComp.SR.parsSyntaxError())
         Some(ident("return", (rhs parseState 1))) } 
 
+/* An optional type application in attribute application */
+opt_attributeTyApp:
+  | opt_HIGH_PRECEDENCE_TYAPP typeArgsActual
+      { Some $2 }
+  | /* EMPTY */
+      { None }
+
 /* Flags on a member */
 memberFlags: 
   | STATIC MEMBER 

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

@@ -257,6 +257,11 @@
         <target state="translated">řez od konce</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureGenericAttributes">
+        <source>Allow generic attributes</source>
+        <target state="new">Allow generic attributes</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureImplicitYield">
         <source>implicit yield</source>
         <target state="translated">implicitní yield</target>
@@ -382,19 +387,16 @@
         <target state="translated">reprezentace struktury aktivních vzorů</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureTryWithInSeqExpressions">
         <source>Support for try-with in sequence expressions</source>
         <target state="new">Support for try-with in sequence expressions</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenCopyAndUpdateRecordChangesAllFields">
         <source>Raises warnings when an copy-and-update record expression changes all fields of a record.</source>
         <target state="new">Raises warnings when an copy-and-update record expression changes all fields of a record.</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenInliningMethodImplNoInlineMarkedFunction">
         <source>Raises warnings when 'let inline ... =' is used together with [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;] attribute. Function is not getting inlined.</source>
         <target state="translated">Vyvolá upozornění, když se použije „let inline ... =“ společně s atributem [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;]. Funkce není vkládána.</target>
@@ -880,6 +882,11 @@
         <target state="translated">Pole {0} se v tomto anonymním typu záznamu vyskytuje vícekrát.</target>
         <note />
       </trans-unit>
+      <trans-unit id="tcAttributeTypeArgumentUsesTypeParameters">
+        <source>An attribute type argument cannot use type parameters.</source>
+        <target state="new">An attribute type argument cannot use type parameters.</target>
+        <note />
+      </trans-unit>
       <trans-unit id="tcAugmentationsCannotHaveAttributes">
         <source>Attributes cannot be applied to type extensions.</source>
         <target state="translated">Atributy nejde použít pro rozšíření typů.</target>

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

@@ -257,6 +257,11 @@
         <target state="translated">Segmentierung ab Ende</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureGenericAttributes">
+        <source>Allow generic attributes</source>
+        <target state="new">Allow generic attributes</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureImplicitYield">
         <source>implicit yield</source>
         <target state="translated">implizite yield-Anweisung</target>
@@ -382,19 +387,16 @@
         <target state="translated">Strukturdarstellung für aktive Muster</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureTryWithInSeqExpressions">
         <source>Support for try-with in sequence expressions</source>
         <target state="new">Support for try-with in sequence expressions</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenCopyAndUpdateRecordChangesAllFields">
         <source>Raises warnings when an copy-and-update record expression changes all fields of a record.</source>
         <target state="new">Raises warnings when an copy-and-update record expression changes all fields of a record.</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenInliningMethodImplNoInlineMarkedFunction">
         <source>Raises warnings when 'let inline ... =' is used together with [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;] attribute. Function is not getting inlined.</source>
         <target state="translated">Löst Warnungen aus, wenn „let inline ... =“ zusammen mit dem Attribut [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;] verwendet wird. Die Funktion wird nicht inline gesetzt.</target>
@@ -880,6 +882,11 @@
         <target state="translated">Das Feld "{0}" ist in diesem anonymen Datensatztyp mehrmals vorhanden.</target>
         <note />
       </trans-unit>
+      <trans-unit id="tcAttributeTypeArgumentUsesTypeParameters">
+        <source>An attribute type argument cannot use type parameters.</source>
+        <target state="new">An attribute type argument cannot use type parameters.</target>
+        <note />
+      </trans-unit>
       <trans-unit id="tcAugmentationsCannotHaveAttributes">
         <source>Attributes cannot be applied to type extensions.</source>
         <target state="translated">Attribute können nicht auf Typerweiterungen angewendet werden.</target>

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

@@ -257,6 +257,11 @@
         <target state="translated">segmentación desde el final</target>
         <note />
       </trans-unit>
+      <trans-unit id="featureGenericAttributes">
+        <source>Allow generic attributes</source>
+        <target state="new">Allow generic attributes</target>
+        <note />
+      </trans-unit>
       <trans-unit id="featureImplicitYield">
         <source>implicit yield</source>
         <target state="translated">elemento yield implícito</target>
@@ -382,19 +387,16 @@
         <target state="translated">representación de struct para modelos activos</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureTryWithInSeqExpressions">
         <source>Support for try-with in sequence expressions</source>
         <target state="new">Support for try-with in sequence expressions</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenCopyAndUpdateRecordChangesAllFields">
         <source>Raises warnings when an copy-and-update record expression changes all fields of a record.</source>
         <target state="new">Raises warnings when an copy-and-update record expression changes all fields of a record.</target>
         <note />
       </trans-unit>
-
       <trans-unit id="featureWarningWhenInliningMethodImplNoInlineMarkedFunction">
         <source>Raises warnings when 'let inline ... =' is used together with [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;] attribute. Function is not getting inlined.</source>
         <target state="translated">Genera advertencias cuando se usa "let inline ... =" junto con el atributo [&lt;MethodImpl(MethodImplOptions.NoInlining)&gt;]. La función no se está insertando.</target>
@@ -880,6 +882,11 @@
         <target state="translated">El campo "{0}" aparece varias veces en este tipo de registro anónimo.</target>
         <note />
       </trans-unit>
+      <trans-unit id="tcAttributeTypeArgumentUsesTypeParameters">
+        <source>An attribute type argument cannot use type parameters.</source>
+        <target state="new">An attribute type argument cannot use type parameters.</target>
+        <note />
+      </trans-unit>
       <trans-unit id="tcAugmentationsCannotHaveAttributes">
         <source>Attributes cannot be applied to type extensions.</source>
         <target state="translated">Los atributos no se pueden aplicar a las extensiones de tipo.</target>