Fix 17731 - Regression, F# 9 compiler cannot find constructor for attribute

src/Compiler/Checking/CheckDeclarations.fs

@@ -431,7 +431,7 @@ module TcRecdUnionAndEnumDeclarations =
     let TcFieldDecl (cenv: cenv) env parent isIncrClass tpenv (isStatic, synAttrs, id: Ident, nameGenerated, ty, isMutable, xmldoc, vis) =
         let g = cenv.g
         let m = id.idRange
-        let attrs, _ = TcAttributesWithPossibleTargets false cenv env AttributeTargets.FieldDecl synAttrs
+        let attrs, _ = TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv env AttributeTargets.FieldDecl synAttrs
 
         let attrsForProperty, attrsForField = attrs |> List.partition (fun (attrTargets, _) -> (attrTargets &&& AttributeTargets.Property) <> enum 0) 
         let attrsForProperty = (List.map snd attrsForProperty) 
@@ -455,7 +455,7 @@ module TcRecdUnionAndEnumDeclarations =
         match parent with
         | Parent tcref when useGenuineField tcref.Deref rfspec ->
             // Recheck the attributes for errors if the definition only generates a field
-            TcAttributesWithPossibleTargets false cenv env AttributeTargets.FieldDeclRestricted synAttrs |> ignore
+            TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv env AttributeTargets.FieldDeclRestricted synAttrs |> ignore
         | _ -> ()
         rfspec
 
@@ -2909,9 +2909,9 @@ module EstablishTypeDefinitionCores =
 
                 if reportAttributeTargetsErrors then
                     if hasStructAttr then
-                        TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Struct synAttrs |> ignore
+                        TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Struct synAttrs |> ignore
                     else
-                        TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Class synAttrs |> ignore
+                        TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Class synAttrs |> ignore
 
                 // Note: the table of union cases is initially empty
                 Construct.MakeUnionRepr []
@@ -2934,9 +2934,9 @@ module EstablishTypeDefinitionCores =
 
                 if reportAttributeTargetsErrors then
                     if hasStructAttr then
-                        TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Struct synAttrs |> ignore
+                        TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Struct synAttrs |> ignore
                     else
-                        TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Class synAttrs |> ignore
+                        TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Class synAttrs |> ignore
 
                 // Note: the table of record fields is initially empty
                 TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpRecord)
@@ -2952,19 +2952,19 @@ module EstablishTypeDefinitionCores =
                         match kind with
                         | SynTypeDefnKind.Class ->
                             if reportAttributeTargetsErrors then
-                                TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Class synAttrs |> ignore
+                                TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Class synAttrs |> ignore
                             TFSharpClass
                         | SynTypeDefnKind.Interface ->
                             if reportAttributeTargetsErrors then
-                                TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Interface synAttrs |> ignore
+                                TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Interface synAttrs |> ignore
                             TFSharpInterface
                         | SynTypeDefnKind.Delegate _ ->
                             if reportAttributeTargetsErrors then
-                                TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Delegate synAttrs |> ignore
+                                TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Delegate synAttrs |> ignore
                             TFSharpDelegate (MakeSlotSig("Invoke", g.unit_ty, [], [], [], None))
                         | SynTypeDefnKind.Struct ->
                             if reportAttributeTargetsErrors then
-                                TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Struct synAttrs |> ignore
+                                TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Struct synAttrs |> ignore
                             TFSharpStruct 
                         | _ -> error(InternalError("should have inferred tycon kind", m))
 
@@ -2973,7 +2973,7 @@ module EstablishTypeDefinitionCores =
             | SynTypeDefnSimpleRepr.Enum _ ->
                 noCLIMutableAttributeCheck()
                 if reportAttributeTargetsErrors then
-                    TcAttributesWithPossibleTargets false cenv envinner AttributeTargets.Enum synAttrs |> ignore
+                    TcAttributesWithPossibleTargets TcCanFail.IgnoreMemberResoutionError cenv envinner AttributeTargets.Enum synAttrs |> ignore
                 TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpEnum)
 
         // OK, now fill in the (partially computed) type representation
@@ -4035,7 +4035,7 @@ module EstablishTypeDefinitionCores =
         // Phase 1B. Establish the kind of each type constructor 
         // Here we run InferTyconKind and record partial information about the kind of the type constructor. 
         // This means FSharpTyconKind is set, which means isSealedTy, isInterfaceTy etc. give accurate results. 
-        let withAttrs = 
+        let withAttrs =
             (envMutRecPrelim, withEnvs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconOpt) -> 
                 let res = 
                     match origInfo, tyconOpt with 
@@ -5202,7 +5202,7 @@ let TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial
     let mutRecDefnsChecked, envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent typeNames tpenv m scopem mutRecNSInfo mutRecDefns true
 
     // Check the assembly attributes
-    let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs
+    let attrs, _ = TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv envAfter AttributeTargets.Top synAttrs
 
     // Check the non-escaping condition as we build the list of module expressions on the way back up 
     let moduleContents = TcMutRecDefsFinish cenv mutRecDefnsChecked m 
@@ -5279,7 +5279,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
           return! failwith "unreachable"
 
       | SynModuleDecl.Attributes (Attributes synAttrs, _) -> 
-          let attrs, _ = TcAttributesWithPossibleTargets false cenv env AttributeTargets.Top synAttrs
+          let attrs, _ = TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv env AttributeTargets.Top synAttrs
           return ([], [], attrs), env, env
 
       | SynModuleDecl.HashDirective _ -> 

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -1010,6 +1010,13 @@ let TranslatePartialValReprInfo tps (PrelimValReprInfo (argsData, retData)) =
 // Members
 //-------------------------------------------------------------------------
 
+
+[<RequireQualifiedAccess>]
+type TcCanFail =
+    | IgnoreMemberResoutionError
+    | IgnoreAllErrors
+    | ReportAllErrors
+
 let TcAddNullnessToType (warn: bool) (cenv: cenv) (env: TcEnv) nullness innerTyC m =
     let g = cenv.g
     if g.langFeatureNullness then
@@ -10869,7 +10876,7 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt
             // For all but attributes positioned at the return value, disallow implicitly
             // targeting the return value.
             let tgtEx = if isRet then enum 0 else AttributeTargets.ReturnValue
-            let attrs, _ = TcAttributesMaybeFailEx false cenv envinner tgt tgtEx attrs
+            let attrs, _ = TcAttributesMaybeFailEx TcCanFail.ReportAllErrors cenv envinner tgt tgtEx attrs
             let attrs: Attrib list = attrs
             if attrTgt = enum 0 && not (isNil attrs) then
                 for attr in attrs do
@@ -11131,7 +11138,7 @@ and TcAttributeTargetsOnLetBindings (cenv: cenv) env attrs overallPatTy overallE
         else
             AttributeTargets.ReturnValue ||| AttributeTargets.Field ||| AttributeTargets.Property
 
-    TcAttributesWithPossibleTargets false cenv env attrTgt attrs |> ignore
+    TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv env attrTgt attrs |> ignore
 
 and TcLiteral (cenv: cenv) overallTy env tpenv (attrs, synLiteralValExpr) =
 
@@ -11291,7 +11298,7 @@ and TcAttributeEx canFail (cenv: cenv) (env: TcEnv) attrTgt attrEx (synAttr: Syn
                 error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(), mAttr))
 
         match ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty with
-        | Exception _ when canFail -> [ ], true
+        | Exception _ when canFail = TcCanFail.IgnoreAllErrors || canFail = TcCanFail.IgnoreMemberResoutionError -> [ ], true
         | res ->
 
         let item = ForceRaise res
@@ -11396,11 +11403,11 @@ and TcAttributesMaybeFail canFail cenv env attrTgt synAttribs =
     TcAttributesMaybeFailEx canFail cenv env attrTgt (enum 0) synAttribs
 
 and TcAttributesCanFail cenv env attrTgt synAttribs =
-    let attrs, didFail = TcAttributesMaybeFail true cenv env attrTgt synAttribs
+    let attrs, didFail = TcAttributesMaybeFail TcCanFail.IgnoreAllErrors cenv env attrTgt synAttribs
     attrs, (fun () -> if didFail then TcAttributes cenv env attrTgt synAttribs else attrs)
 
 and TcAttributes cenv env attrTgt synAttribs =
-    TcAttributesMaybeFail false cenv env attrTgt synAttribs |> fst
+    TcAttributesMaybeFail TcCanFail.ReportAllErrors cenv env attrTgt synAttribs |> fst
 
 //-------------------------------------------------------------------------
 // TcLetBinding

src/Compiler/Checking/Expressions/CheckExpressions.fsi

@@ -345,6 +345,12 @@ type PostSpecialValsRecursiveBinding =
     { ValScheme: ValScheme
       Binding: Binding }
 
+[<RequireQualifiedAccess>]
+type TcCanFail =
+    | IgnoreMemberResoutionError
+    | IgnoreAllErrors
+    | ReportAllErrors
+
 /// Represents a recursive binding after it has been both checked and generalized, but
 /// before initialization recursion has been rewritten
 type PreInitializationGraphEliminationBinding =
@@ -598,7 +604,7 @@ val TcAttributesCanFail:
 
 /// Check a set of attributes which can only target specific elements
 val TcAttributesWithPossibleTargets:
-    canFail: bool ->
+    canFail: TcCanFail ->
     cenv: TcFileState ->
     env: TcEnv ->
     attrTgt: AttributeTargets ->

tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/AttributeUsage.fs

@@ -1,4 +1,4 @@
-// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
 
 namespace Conformance.BasicGrammarElements
 
@@ -875,7 +875,7 @@ type InterruptibleLazy<'T> private (valueFactory: unit -> 'T) =
             (Error 948, Line 8, Col 6, Line 8, Col 24, "Interface types cannot be sealed")
             (Error 942, Line 14, Col 6, Line 14, Col 33, "Delegate types are always sealed")
         ]
-        
+
     // SOURCE= E_StructLayout01.fs	# E_StructLayout01.fs
     [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_StructLayout01.fs"|])>]
     let ``E_StructLayout01 9.0`` compilation =
@@ -890,7 +890,7 @@ type InterruptibleLazy<'T> private (valueFactory: unit -> 'T) =
             (Error 937, Line 14, Col 6, Line 14, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
             (Error 937, Line 17, Col 6, Line 17, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
         ]
-    
+
     // SOURCE=E_StructLayout01.fs	# E_StructLayout01.fs
     [<Theory; Directory(__SOURCE_DIRECTORY__, Includes=[|"E_StructLayout01.fs"|])>]
     let ``E_StructLayout01 preview`` compilation =
@@ -904,4 +904,32 @@ type InterruptibleLazy<'T> private (valueFactory: unit -> 'T) =
             (Error 937, Line 11, Col 6, Line 11, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
             (Error 937, Line 14, Col 6, Line 14, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
             (Error 937, Line 17, Col 6, Line 17, Col 8, "Only structs and classes without primary constructors may be given the 'StructLayout' attribute")
-        ]
+        ]
+
+#if NETCOREAPP
+    let missingConstructorRepro =
+        """
+open System.Text.Json.Serialization
+
+type internal ApplicationTenantJsonDerivedTypeAttribute () =
+    inherit JsonDerivedTypeAttribute (typeof<ApplicationTenant>, "a")
+
+// --------------------------------------------------------------------------
+// IMPORTANT: Read ReadMe before modifying this сlass and any referenced types
+// --------------------------------------------------------------------------
+and [<ApplicationTenantJsonDerivedType>]
+    ApplicationTenant
+    [<JsonConstructor>] (id, name, loginProvider, allowedDomains, authorizedTenants, properties) =
+
+    member _.Id = ""
+        """
+
+    [<InlineData("8.0")>]
+    [<InlineData("preview")>]
+    [<Theory>]
+    let ``Regression for - F# 9 compiler cannot find constructor for attribute`` langVersion =
+        FSharp missingConstructorRepro
+        |> withLangVersion langVersion
+        |> verifyCompile
+        |> shouldSucceed
+#endif