From f6364a85a98259de7868c8ceb7e1ba93bc985f89 Mon Sep 17 00:00:00 2001 From: KevinRansom Date: Mon, 16 Sep 2024 00:33:47 -0700 Subject: [PATCH 1/2] Fix 17731 --- src/Compiler/Checking/CheckDeclarations.fs | 28 +++++++-------- .../Checking/Expressions/CheckExpressions.fs | 17 ++++++--- .../Checking/Expressions/CheckExpressions.fsi | 8 ++++- .../AttributeUsage/AttributeUsage.fs | 36 ++++++++++++++++--- 4 files changed, 65 insertions(+), 24 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 96d3bb2b28d..e739169ea9c 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/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 _ -> diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index a3cee51a48d..072bb0a3ee8 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -1010,6 +1010,13 @@ let TranslatePartialValReprInfo tps (PrelimValReprInfo (argsData, retData)) = // Members //------------------------------------------------------------------------- + +[] +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 diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index 6612194d1a5..f8e2ba1b196 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -345,6 +345,12 @@ type PostSpecialValsRecursiveBinding = { ValScheme: ValScheme Binding: Binding } +[] +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 -> diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/AttributeUsage.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/AttributeUsage.fs index adfe0e3cfcb..bf413c777d3 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/BasicGrammarElements/CustomAttributes/AttributeUsage/AttributeUsage.fs +++ b/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 [] 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 [] 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") - ] \ No newline at end of file + ] + +#if NETCOREAPP + let missingConstructorRepro = + """ +open System.Text.Json.Serialization + +type internal ApplicationTenantJsonDerivedTypeAttribute () = + inherit JsonDerivedTypeAttribute (typeof, "a") + +// -------------------------------------------------------------------------- +// IMPORTANT: Read ReadMe before modifying this сlass and any referenced types +// -------------------------------------------------------------------------- +and [] + ApplicationTenant + [] (id, name, loginProvider, allowedDomains, authorizedTenants, properties) = + + member _.Id = "" + """ + + [] + [] + [] + let ``Regression for - F# 9 compiler cannot find constructor for attribute`` langVersion = + FSharp missingConstructorRepro + |> withLangVersion langVersion + |> verifyCompile + |> shouldSucceed +#endif From 2174254ddf1615b2f8db1c56236be97ef817f1b7 Mon Sep 17 00:00:00 2001 From: KevinRansom Date: Mon, 16 Sep 2024 01:09:10 -0700 Subject: [PATCH 2/2] fantomas --- src/Compiler/Checking/Expressions/CheckExpressions.fsi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index f8e2ba1b196..cccb19f8abf 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -347,9 +347,9 @@ type PostSpecialValsRecursiveBinding = [] type TcCanFail = - | IgnoreMemberResoutionError - | IgnoreAllErrors - | ReportAllErrors + | IgnoreMemberResoutionError + | IgnoreAllErrors + | ReportAllErrors /// Represents a recursive binding after it has been both checked and generalized, but /// before initialization recursion has been rewritten