diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 221cb6bde0..bb23628937 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -51,6 +51,7 @@ * Fix internal error when using custom attribute with `[]` value type parameter and no `[]`. ([Issue #8353](https://github.com/dotnet/fsharp/issues/8353), [PR #19484](https://github.com/dotnet/fsharp/pull/19484)) * Fix parallel compilation of scripts ([PR #19649](https://github.com/dotnet/fsharp/pull/19649)) * Parser: fix unexpected diagnostics in debug builds, improve error messages ([PR #19730](https://github.com/dotnet/fsharp/pull/19730)) +* Fix #5795: Allow attributes defined in a `module rec` / `namespace rec` scope to be used on union cases, record fields, and generic type parameters of types in the same recursive scope. ([Issue #5795](https://github.com/dotnet/fsharp/issues/5795), [PR #19744](https://github.com/dotnet/fsharp/pull/19744)) ### Added diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 149f8217e9..71c04876d8 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -428,11 +428,14 @@ 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 TcCanFail.ReportAllErrors cenv env AttributeTargets.FieldDecl synAttrs + // CanFail: attrs from same rec group may not resolve yet; fixup re-resolves in Phase1G. + let attrs, getFinalAttrs = TcAttributesWithPossibleTargetsCanFail cenv env AttributeTargets.FieldDecl synAttrs - let attrsForProperty, attrsForField = attrs |> List.partition (fun (attrTargets, _) -> (attrTargets &&& AttributeTargets.Property) <> enum 0) - let attrsForProperty = (List.map snd attrsForProperty) - let attrsForField = (List.map snd attrsForField) + let splitAttrs (attrsWithTargets: (AttributeTargets * Attrib) list) = + let propAttribs, fieldAttribs = attrsWithTargets |> List.partition (fun (attrTargets, _) -> (attrTargets &&& AttributeTargets.Property) <> enum 0) + List.map snd propAttribs, List.map snd fieldAttribs + + let attrsForProperty, attrsForField = splitAttrs attrs let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv ty let fieldFlags = computeValWellKnownFlags g attrsForField let zeroInit = hasFlag fieldFlags (WellKnownValAttributes.DefaultValueAttribute_True ||| WellKnownValAttributes.DefaultValueAttribute_False) @@ -456,7 +459,14 @@ module TcRecdUnionAndEnumDeclarations = // Recheck the attributes for errors if the definition only generates a field TcAttributesWithPossibleTargets TcCanFail.ReportAllErrors cenv env AttributeTargets.FieldDeclRestricted synAttrs |> ignore | _ -> () - rfspec + + let fixupAttrs () = + let finalAttrs = getFinalAttrs () + let propAttribs', fieldAttribs' = splitAttrs finalAttrs + rfspec.rfield_pattribs <- propAttribs' + rfspec.rfield_fattribs <- fieldAttribs' + + rfspec, fixupAttrs let TcAnonFieldDecl cenv env parent tpenv nm (SynField(Attributes attribs, isStatic, idOpt, ty, isMutable, xmldoc, vis, m, _)) = let mName = m.MakeSynthetic() @@ -477,7 +487,10 @@ module TcRecdUnionAndEnumDeclarations = Some(TcFieldDecl cenv env parent isIncrClass tpenv (isStatic, attribs, id, false, ty, isMutable, xmlDoc, vis)) let TcNamedFieldDecls cenv env parent isIncrClass tpenv fields = - fields |> List.choose (TcNamedFieldDecl cenv env parent isIncrClass tpenv) + let fieldsAndFixups = fields |> List.choose (TcNamedFieldDecl cenv env parent isIncrClass tpenv) + let rfields = fieldsAndFixups |> List.map fst + let fixups = fieldsAndFixups |> List.map snd + rfields, (fun () -> fixups |> List.iter (fun f -> f ())) //------------------------------------------------------------------------- // Bind other elements of type definitions (constructors etc.) @@ -529,11 +542,11 @@ module TcRecdUnionAndEnumDeclarations = CheckUnionCaseName cenv id hasRQAAttribute - let rfields, recordTy = + let rfields, fixupFieldAttrs, recordTy = match args with | SynUnionCaseKind.Fields flds -> let nFields = flds.Length - let rfields = + let rfieldsAndFixups = flds |> List.mapi (fun i (SynField (idOpt = idOpt) as fld) -> match idOpt, parent with @@ -545,10 +558,12 @@ module TcRecdUnionAndEnumDeclarations = Some(TcAnonFieldDecl cenv env parent tpenv (mkUnionCaseFieldName nFields i) fld) ) |> List.choose (fun x -> x) + let rfields = rfieldsAndFixups |> List.map fst + let fieldFixups = rfieldsAndFixups |> List.map snd ValidateFieldNames(flds, rfields) - rfields, thisTy + rfields, (fun () -> fieldFixups |> List.iter (fun f -> f ())), thisTy | SynUnionCaseKind.FullType (ty, arity) -> let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurrence.UseInType WarnOnIWSAM.Yes env tpenv ty @@ -567,7 +582,7 @@ module TcRecdUnionAndEnumDeclarations = if not (typeEquiv g recordTy thisTy) then errorR(Error(FSComp.SR.tcReturnTypesForUnionMustBeSameAsType(), m)) - rfields, recordTy + rfields, (fun () -> ()), recordTy let names = rfields |> Seq.filter (fun f -> not f.rfield_name_generated) @@ -576,7 +591,8 @@ module TcRecdUnionAndEnumDeclarations = let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs let xmlDoc = xmldoc.ToXmlDoc(checkXmlDocs, Some names) - let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs + // CanFail: attrs from same rec group may not resolve yet; fixup re-resolves in Phase1G. + let attrs, getFinalAttrs = TcAttributesCanFail cenv env AttributeTargets.UnionCaseDecl synAttrs (* The attributes of a union case decl get attached to the generated "static factory" method. Enforce union-cases AttributeTargets: @@ -604,14 +620,20 @@ module TcRecdUnionAndEnumDeclarations = if hasNotMethodTarget then warning(Error(FSComp.SR.tcAttributeIsNotValidForUnionCaseWithFields(), id.idRange))) - Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis + let unionCase = Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis + let fixupAttrs () = + unionCase.Attribs <- getFinalAttrs () + fixupFieldAttrs () + unionCase, fixupAttrs let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) hasRQAAttribute tpenv unionCases = - let unionCasesR = + let unionCasesAndFixups = unionCases |> List.filter (fun (SynUnionCase(_, SynIdent(id, _), _, _, _, _, _)) -> id.idText <> "") |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv hasRQAAttribute) - unionCasesR |> CheckDuplicates (fun uc -> uc.Id) "union case" + let unionCasesR = unionCasesAndFixups |> List.map fst + let fixups = unionCasesAndFixups |> List.map snd + unionCasesR |> CheckDuplicates (fun uc -> uc.Id) "union case", (fun () -> fixups |> List.iter (fun f -> f ())) let MakeEnumCaseSpec g cenv env parent attrs thisTy caseRange (caseIdent: Ident) (xmldoc: PreXmlDoc) value = let vis, _ = ComputeAccessAndCompPath g env None caseRange None None parent @@ -2430,7 +2452,10 @@ module TcExceptionDeclarations = CallNameResolutionSink cenv.tcSink (fieldId.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurrence.Binding, env.AccessRights) | _ -> () - TcRecdUnionAndEnumDeclarations.TcAnonFieldDecl cenv env parent emptyUnscopedTyparEnv (mkExceptionFieldName i) fdef) + let rfield, fixupFieldAttrs = TcRecdUnionAndEnumDeclarations.TcAnonFieldDecl cenv env parent emptyUnscopedTyparEnv (mkExceptionFieldName i) fdef + // Exceptions aren't in rec groups — finalize field attrs eagerly. + fixupFieldAttrs () + rfield) TcRecdUnionAndEnumDeclarations.ValidateFieldNames(args, args') let repr = match reprIdOpt with @@ -2767,12 +2792,14 @@ module EstablishTypeDefinitionCores = let private TcTyconDefnCore_Phase1A_BuildInitialTycon (cenv: cenv) env parent (MutRecDefnsPhase1DataForTycon(synTyconInfo, synTyconRepr, _, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, _)) = let g = cenv.g let (SynComponentInfo (_, TyparDecls synTypars, _, id, xmlDoc, preferPostfix, synVis, _)) = synTyconInfo - let checkedTypars = TcTyparDecls cenv env synTypars + let checkedTypars, fixupTyparAttrs = TcTyparDecls cenv env synTypars id |> List.iter (CheckNamespaceModuleOrTypeName g) match synTyconRepr with | SynTypeDefnSimpleRepr.Exception synExnDefnRepr -> - TcExceptionDeclarations.TcExnDefnCore_Phase1A g cenv env parent synExnDefnRepr + // Exceptions have no user typars — finalize eagerly. + fixupTyparAttrs env + TcExceptionDeclarations.TcExnDefnCore_Phase1A g cenv env parent synExnDefnRepr, (fun _ -> ()) | _ -> let id = ComputeTyconName (id, (match synTyconRepr with SynTypeDefnSimpleRepr.TypeAbbrev _ -> false | _ -> true), checkedTypars) @@ -2830,9 +2857,11 @@ module EstablishTypeDefinitionCores = let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs let xmlDoc = xmlDoc.ToXmlDoc(checkXmlDocs, Some paramNames ) - Construct.NewTycon - (cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, - xmlDoc, preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmodTy) + let tycon = + Construct.NewTycon + (cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, + xmlDoc, preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmodTy) + tycon, fixupTyparAttrs //------------------------------------------------------------------------- /// Establishing type definitions: early phase: work out the basic kind of the type definition @@ -3389,6 +3418,8 @@ module EstablishTypeDefinitionCores = let private TcTyconDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) envinner tpenv inSig (MutRecDefnsPhase1DataForTycon(_, synTyconRepr, _, _, _, _)) (tycon: Tycon) (attrs: Attribs) = let g = cenv.g let m = tycon.Range + // Survives RecoverableException so captured fixup isn't lost on recovery path. + let latestFixupReprAttrs = ref (fun () -> ()) try let id = tycon.Id let thisTyconRef = mkLocalTyconRef tycon @@ -3519,6 +3550,7 @@ module EstablishTypeDefinitionCores = let item = Item.UnionCase(info, false) CallNameResolutionSink cenv.tcSink (unionCase.Range, nenv, item, emptyTyparInst, ItemOccurrence.Binding, ad) + let mutable fixupReprAttrs = fun () -> () let typeRepr, baseValOpt, safeInitInfo = match synTyconRepr with @@ -3578,7 +3610,9 @@ module EstablishTypeDefinitionCores = structLayoutAttributeCheck false let hasRQAAttribute = EntityHasWellKnownAttribute cenv.g WellKnownEntityAttributes.RequireQualifiedAccessAttribute tycon - let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst hasRQAAttribute tpenv unionCases + let unionCases, fixupAttrs = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst hasRQAAttribute tpenv unionCases + fixupReprAttrs <- fixupAttrs + latestFixupReprAttrs.Value <- fixupAttrs multiCaseUnionStructCheck unionCases writeFakeUnionCtorsToSink unionCases @@ -3592,7 +3626,9 @@ module EstablishTypeDefinitionCores = noAbstractClassAttributeCheck() noAllowNullLiteralAttributeCheck() structLayoutAttributeCheck true // these are allowed for records - let recdFields = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent false tpenv fields + let recdFields, fixupRecdFieldAttrs = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent false tpenv fields + fixupReprAttrs <- fixupRecdFieldAttrs + latestFixupReprAttrs.Value <- fixupRecdFieldAttrs recdFields |> CheckDuplicates (fun f -> f.Id) "field" |> ignore writeFakeRecordFieldsToSink recdFields CallEnvSink cenv.tcSink (mRepr, envinner.NameEnv, ad) @@ -3618,7 +3654,9 @@ module EstablishTypeDefinitionCores = TAsmRepr s, None, NoSafeInitInfo | SynTypeDefnSimpleRepr.General (kind, inherits, slotsigs, fields, isConcrete, isIncrClass, implicitCtorSynPats, _) -> - let userFields = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent isIncrClass tpenv fields + let userFields, fixupUserFieldAttrs = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent isIncrClass tpenv fields + fixupReprAttrs <- fixupUserFieldAttrs + latestFixupReprAttrs.Value <- fixupUserFieldAttrs let implicitStructFields = [ // For structs with an implicit ctor, determine the fields immediately based on the arguments match implicitCtorSynPats with @@ -3807,10 +3845,10 @@ module EstablishTypeDefinitionCores = errorR(Error(FSComp.SR.tcConditionalAttributeUsage(), m)) | _ -> () - (baseValOpt, safeInitInfo) + (baseValOpt, safeInitInfo), fixupReprAttrs with RecoverableException exn -> errorRecovery exn m - None, NoSafeInitInfo + (None, NoSafeInitInfo), latestFixupReprAttrs.Value /// Check that a set of type definitions is free of cycles in abbreviations let private TcTyconDefnCore_CheckForCyclicAbbreviations tycons = @@ -4039,6 +4077,8 @@ module EstablishTypeDefinitionCores = let TcMutRecDefns_Phase1 mkLetInfo (cenv: cenv) envInitial parent typeNames inSig tpenv m scopem mutRecNSInfo (mutRecDefns: MutRecShapes) = + // Typar attr fixups from Phase1A — deferred because rec-scope attrs aren't wired yet. + let typarAttrFixups = System.Collections.Generic.Dictionary unit>() // Phase1A - build Entity for type definitions, exception definitions and module definitions. // Also for abbreviations of any of these. Augmentations are skipped in this phase. let withEntities = @@ -4054,7 +4094,9 @@ module EstablishTypeDefinitionCores = let (MutRecDefnsPhase1DataForTycon(isAtOriginalTyconDefn=isAtOriginalTyconDefn)) = typeDefCore let tyconOpt = if isAtOriginalTyconDefn then - Some (TcTyconDefnCore_Phase1A_BuildInitialTycon cenv envForDecls innerParent typeDefCore) + let tycon, fixupTyparAttrs = TcTyconDefnCore_Phase1A_BuildInitialTycon cenv envForDecls innerParent typeDefCore + typarAttrFixups[tycon.Stamp] <- fixupTyparAttrs + Some tycon else None (typeDefCore, tyconMemberInfo, innerParent), tyconOpt) @@ -4171,14 +4213,22 @@ module EstablishTypeDefinitionCores = // checking the members. let withBaseValsAndSafeInitInfos = (envMutRecPrelim, withAttrs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconAndAttrsOpt) -> - let info = + let info, fixupReprAttrs = match origInfo, tyconAndAttrsOpt with | (typeDefCore, _, _), Some (tycon, (attrs, _)) -> TcTyconDefnCore_Phase1G_EstablishRepresentation cenv envForDecls tpenv inSig typeDefCore tycon attrs - | _ -> None, NoSafeInitInfo + | _ -> (None, NoSafeInitInfo), (fun () -> ()) let tyconOpt, fixupFinalAttrs = match tyconAndAttrsOpt with - | None -> None, (fun () -> ()) - | Some (tycon, (_prelimAttrs, getFinalAttrs)) -> Some tycon, (fun () -> tycon.entity_attribs <- WellKnownEntityAttribs.Create(getFinalAttrs())) + | None -> None, fixupReprAttrs + | Some (tycon, (_prelimAttrs, getFinalAttrs)) -> + let fixupTyparAttrs = + match typarAttrFixups.TryGetValue tycon.Stamp with + | true, f -> f + | _ -> fun _ -> () + Some tycon, (fun () -> + tycon.entity_attribs <- WellKnownEntityAttribs.Create(getFinalAttrs()) + fixupTyparAttrs envForDecls + fixupReprAttrs()) (origInfo, tyconOpt, fixupFinalAttrs, info)) @@ -4265,7 +4315,8 @@ module TcDeclarations = let nReqTypars = reqTypars.Length - let declaredTypars = TcTyparDecls cenv envForDecls synTypars + let declaredTypars, fixupTypars = TcTyparDecls cenv envForDecls synTypars + fixupTypars envForDecls let envForTycon = AddDeclaredTypars CheckForDuplicateTypars declaredTypars envForDecls let _tpenv = TcTyparConstraints cenv NoNewTypars CheckCxs ItemOccurrence.UseInType envForTycon emptyUnscopedTyparEnv synTyparCxs declaredTypars |> List.iter (SetTyparRigid envForDecls.DisplayEnv m) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 30d49e776c..555c604953 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -4304,7 +4304,8 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv synMemberSig m = and TcValSpec (cenv: cenv) env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv synValSig attrs = let g = cenv.g let (SynValSig(ident=SynIdent(id,_); explicitTypeParams=ValTyparDecls (synTypars, synTyparConstraints, _); synType=ty; arity=valSynInfo; range=m)) = synValSig - let declaredTypars = TcTyparDecls cenv env synTypars + let declaredTypars, fixupTypars = TcTyparDecls cenv env synTypars + fixupTypars env let (ContainerInfo(altActualParent, tcrefContainerInfo)) = containerInfo let enclosingDeclaredTypars, memberContainerInfo, thisTyOpt, declKind = @@ -4502,20 +4503,35 @@ and TcTypeOrMeasureParameter kindOpt cenv (env: TcEnv) newOk tpenv (SynTypar(id, and TcTypar (cenv: cenv) env newOk tpenv tp : Typar * UnscopedTyparEnv = TcTypeOrMeasureParameter (Some TyparKind.Type) cenv env newOk tpenv tp -and TcTyparDecl (cenv: cenv) env synTyparDecl = +and TcTyparDecl (cenv: cenv) (env: TcEnv) synTyparDecl = let g = cenv.g let (SynTyparDecl (attributes = Attributes synAttrs; typar = synTypar)) = synTyparDecl let (SynTypar (ident = id)) = synTypar - let attrs = TcAttributes cenv env AttributeTargets.GenericParameter synAttrs - let hasMeasureAttr = HasFSharpAttribute g g.attrib_MeasureAttribute attrs - let hasEqDepAttr = HasFSharpAttribute g g.attrib_EqualityConditionalOnAttribute attrs - let hasCompDepAttr = HasFSharpAttribute g g.attrib_ComparisonConditionalOnAttribute attrs - let attrs = attrs |> filterOutWellKnownAttribs g WellKnownEntityAttributes.MeasureAttribute WellKnownValAttributes.None + // Prelim pass: suppress diagnostics so rec-scope attrs (not yet wired) don't emit FS0039. + // Framework attrs (Measure, EqualityConditionalOn, etc.) resolve here for kind inference. + // Fixup thunk re-resolves with the final env. + let prelimCapture = CapturingDiagnosticsLogger("TcTyparDecl prelim") + let prelimAttrs, didFailReported = + let oldLogger = DiagnosticsThreadStatics.DiagnosticsLogger + try + SetThreadDiagnosticsLoggerNoUnwind prelimCapture + TcAttributesMaybeFail TcCanFail.IgnoreAllErrors cenv env AttributeTargets.GenericParameter synAttrs + finally + SetThreadDiagnosticsLoggerNoUnwind oldLogger + // Failed if: TcCanFail reported failure, attrs were dropped, or diagnostics were suppressed. + let didFail = + didFailReported + || List.length prelimAttrs < List.length synAttrs + || not prelimCapture.Diagnostics.IsEmpty + let hasMeasureAttr = HasFSharpAttribute g g.attrib_MeasureAttribute prelimAttrs + let hasEqDepAttr = HasFSharpAttribute g g.attrib_EqualityConditionalOnAttribute prelimAttrs + let hasCompDepAttr = HasFSharpAttribute g g.attrib_ComparisonConditionalOnAttribute prelimAttrs + let attrsForTypar = prelimAttrs |> filterOutWellKnownAttribs g WellKnownEntityAttributes.MeasureAttribute WellKnownValAttributes.None let kind = if hasMeasureAttr then TyparKind.Measure else TyparKind.Type - let tp = Construct.NewTypar (kind, TyparRigidity.WarnIfNotRigid, synTypar, false, TyparDynamicReq.Yes, attrs, hasEqDepAttr, hasCompDepAttr) + let tp = Construct.NewTypar (kind, TyparRigidity.WarnIfNotRigid, synTypar, false, TyparDynamicReq.Yes, attrsForTypar, hasEqDepAttr, hasCompDepAttr) - match attrs with + match attrsForTypar with | ValAttribString g WellKnownValAttributes.CompiledNameAttribute compiledName -> tp.SetILName (Some compiledName) | _ -> @@ -4524,10 +4540,21 @@ and TcTyparDecl (cenv: cenv) env synTyparDecl = CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, emptyTyparInst, ItemOccurrence.UseInType, env.eAccessRights) - tp + let fixupAttrs (envForFinal: TcEnv) = + // Re-resolve only if prelim pass suppressed errors. + if didFail then + let finalAttrs = + TcAttributes cenv envForFinal AttributeTargets.GenericParameter synAttrs + |> filterOutWellKnownAttribs g WellKnownEntityAttributes.MeasureAttribute WellKnownValAttributes.None + tp.SetAttribs finalAttrs + + tp, fixupAttrs and TcTyparDecls (cenv: cenv) env synTypars = - List.map (TcTyparDecl cenv env) synTypars + let results = List.map (TcTyparDecl cenv env) synTypars + let typars = results |> List.map fst + let fixups = results |> List.map snd + typars, (fun envForFinal -> fixups |> List.iter (fun f -> f envForFinal)) /// Check and elaborate a syntactic type or unit-of-measure /// @@ -11502,7 +11529,8 @@ and TcLiteral (cenv: cenv) overallTy env tpenv (attrs, synLiteralValExpr) = else hasLiteralAttr, None and TcBindingTyparDecls alwaysRigid cenv env tpenv (ValTyparDecls(synTypars, synTyparConstraints, infer)) = - let declaredTypars = TcTyparDecls cenv env synTypars + let declaredTypars, fixupTypars = TcTyparDecls cenv env synTypars + fixupTypars env let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTypars env let tpenv = TcTyparConstraints cenv NoNewTypars CheckCxs ItemOccurrence.UseInType envinner tpenv synTyparConstraints @@ -11811,6 +11839,13 @@ and TcAttributesCanFail 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 TcAttributesWithPossibleTargetsCanFail cenv env attrTgt synAttribs = + let attrs, didFail = TcAttributesWithPossibleTargetsEx TcCanFail.IgnoreAllErrors cenv env attrTgt (enum 0) synAttribs + attrs, (fun () -> + if didFail then + TcAttributesWithPossibleTargetsEx TcCanFail.ReportAllErrors cenv env attrTgt (enum 0) synAttribs |> fst + else attrs) + and TcAttributes cenv env attrTgt synAttribs = TcAttributesMaybeFail TcCanFail.ReportAllErrors cenv env attrTgt synAttribs |> fst @@ -13172,7 +13207,8 @@ let TcAndPublishValSpec (cenv: cenv, env, containerInfo: ContainerInfo, declKind let (SynValSig (attributes=Attributes synAttrs; explicitTypeParams=explicitTypeParams; isInline=isInline; isMutable=mutableFlag; xmlDoc=xmlDoc; accessibility=vis; synExpr=literalExprOpt; range=m)) = synValSig let (ValTyparDecls (synTypars, _, synCanInferTypars)) = explicitTypeParams - let declaredTypars = TcTyparDecls cenv env synTypars + let declaredTypars, fixupTypars = TcTyparDecls cenv env synTypars + fixupTypars env GeneralizationHelpers.CheckDeclaredTyparsPermitted(memFlagsOpt, declaredTypars, m) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fsi b/src/Compiler/Checking/Expressions/CheckExpressions.fsi index d8f801c7c5..63887c6239 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fsi +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fsi @@ -626,6 +626,15 @@ val TcAttributesWithPossibleTargets: synAttribs: SynAttribute list -> (AttributeTargets * Attrib) list * bool +/// Like TcAttributesWithPossibleTargets, but allows failure for rec-scope attrs. +/// Returns prelim attrs + a fixup thunk that re-resolves with the final env. +val TcAttributesWithPossibleTargetsCanFail: + cenv: TcFileState -> + env: TcEnv -> + attrTgt: AttributeTargets -> + synAttribs: SynAttribute list -> + (AttributeTargets * Attrib) list * (unit -> (AttributeTargets * Attrib) list) + /// Check a constant value, e.g. a literal val TcConst: cenv: TcFileState -> overallTy: TType -> m: range -> env: TcEnv -> synConst: SynConst -> Const @@ -808,8 +817,10 @@ val TcTyparConstraints: synConstraints: SynTypeConstraint list -> UnscopedTyparEnv -/// Check a collection of type parameters declarations -val TcTyparDecls: cenv: TcFileState -> env: TcEnv -> synTypars: SynTyparDecl list -> Typar list +/// Check type parameter declarations. +/// Returns typars + fixup thunk for deferred attr resolution in rec scopes. +/// Non-rec callers: invoke the fixup immediately with the same env. +val TcTyparDecls: cenv: TcFileState -> env: TcEnv -> synTypars: SynTyparDecl list -> Typar list * (TcEnv -> unit) /// Check a syntactic type val TcType: diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 2eaa4afe20..b9dd8aa2cd 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -335,6 +335,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/Language/AttributeResolutionInRecursiveScopes.fs b/tests/FSharp.Compiler.ComponentTests/Language/AttributeResolutionInRecursiveScopes.fs new file mode 100644 index 0000000000..86060c1bcc --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Language/AttributeResolutionInRecursiveScopes.fs @@ -0,0 +1,324 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Language + +open Xunit +open FSharp.Test +open FSharp.Test.Compiler + +module AttributeResolutionInRecursiveScopes = + + // Baselines: these attribute positions already worked before #5795. + + [] + let ``attribute on type declaration in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +[] +type A = | A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on let binding in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +[] +let a = () +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on type declaration in namespace rec resolves to attribute defined in same namespace`` () = + Fsx """ +namespace rec Ns + +type CustomAttribute() = inherit System.Attribute() + +[] +type A = | A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on let binding in non-rec module resolves to attribute defined in same module`` () = + Fsx """ +module M + +type CustomAttribute() = inherit System.Attribute() + +[] +let a = () +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on union case in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type A = | [] A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on union case in namespace rec resolves to attribute defined in same namespace`` () = + Fsx """ +namespace rec Ns + +type CustomAttribute() = inherit System.Attribute() + +type A = | [] A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on every case of a DU in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type Shape = + | [] Circle of float + | [] Square of float +""" + |> compile + |> shouldSucceed + + [] + let ``attribute shorthand on union case in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type A = | [] A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on record field in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type R = { [] X: int } +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on multiple record fields in module rec resolves to attributes defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() +type AnotherAttribute() = inherit System.Attribute() + +type R = { + [] X: int + [] Y: string + [] Z: float +} +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on record field in namespace rec resolves to attribute defined in same namespace`` () = + Fsx """ +namespace rec Ns + +type CustomAttribute() = inherit System.Attribute() + +type R = { [] X: int } +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on type parameter in module rec resolves to attribute defined in same module`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type B<[]'a> = | B of 'a +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on type parameter in namespace rec resolves to attribute defined in same namespace`` () = + Fsx """ +namespace rec Ns + +type CustomAttribute() = inherit System.Attribute() + +type B<[]'a> = | B of 'a +""" + |> compile + |> shouldSucceed + + [] + let ``attribute on type parameter combined with framework Measure attribute in module rec compiles`` () = + Fsx """ +module rec M + +type CustomAttribute() = inherit System.Attribute() + +type B<[]'u, []'a> = B of 'a +""" + |> compile + |> shouldSucceed + + // Edge cases + + [] + let ``attribute defined in nested module of rec scope resolves on union case`` () = + Fsx """ +module rec M + +module Nested = + type CustomAttribute() = inherit System.Attribute() + +type A = | [] A +""" + |> compile + |> shouldSucceed + + [] + let ``attribute defined in nested module of rec scope resolves on type parameter`` () = + Fsx """ +module rec M + +module Nested = + type CustomAttribute() = inherit System.Attribute() + +type B<[]'a> = B of 'a +""" + |> compile + |> shouldSucceed + + [] + let ``attribute defined in nested module of rec scope resolves on record field`` () = + Fsx """ +module rec M + +module Nested = + type CustomAttribute() = inherit System.Attribute() + +type R = { [] X: int } +""" + |> compile + |> shouldSucceed + + [] + let ``multiple attributes mixing framework Obsolete and rec-scope custom on union case compile`` () = + Fsx """ +module rec M + +open System + +type CustomAttribute() = inherit System.Attribute() + +type A = | [] A +""" + |> ignoreWarnings + |> compile + |> shouldSucceed + + [] + let ``rec-scope attribute shadows outer-scope attribute on union case in nested rec module`` () = + Fsx """ +module Root + +type CustomAttribute() = inherit System.Attribute() + +module rec M = + type CustomAttribute() = inherit System.Attribute() + type A = | [] A +""" + |> compile + |> shouldSucceed + + // [] resolves to the user's MeasureAttribute by name, so kind inference breaks. + // Unrelated to #5795 rec-scope fix. + [] + let ``user-defined MeasureAttribute in rec scope does not break framework Measure kind inference`` () = + Fsx """ +module rec M + +type MeasureAttribute() = inherit System.Attribute() + +[] type kg +""" + |> compile + |> shouldSucceed + + // Negative tests — must still error after the fix. + + [] + let ``non-attribute type used on union case in module rec still produces diagnostic`` () = + // FS3242: "does not inherit Attribute" — warning, not error. + Fsx """ +module rec M + +type NotAnAttribute() = class end + +type A = | [] A +""" + |> ignoreWarnings + |> compile + |> shouldSucceed + |> withDiagnosticMessageMatches "does not inherit Attribute" + + [] + let ``unknown attribute name on union case in module rec still errors with FS0039`` () = + Fsx """ +module rec M + +type A = | [] A +""" + |> compile + |> shouldFail + |> withErrorCode 39 + + [] + let ``unknown attribute name on type parameter in module rec still errors with FS0039`` () = + Fsx """ +module rec M + +type B<[]'a> = B of 'a +""" + |> compile + |> shouldFail + |> withErrorCode 39 + + [] + let ``unknown attribute name on record field in module rec still errors with FS0039`` () = + Fsx """ +module rec M + +type R = { [] X: int } +""" + |> compile + |> shouldFail + |> withErrorCode 39