From 96fc407e9604b9ee53bdddc8344856bbc3af6b05 Mon Sep 17 00:00:00 2001 From: Kurt Schelfthout Date: Fri, 2 Dec 2016 22:57:23 +0000 Subject: [PATCH 1/3] Try to fix #557. --- src/fsharp/TastOps.fsi | 1 + src/fsharp/TypeChecker.fs | 51 +++++++++++-------- .../InternalInterfaceWithInternalArgument.fs | 13 +++++ .../env.lst | 3 +- 4 files changed, 47 insertions(+), 21 deletions(-) create mode 100644 tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 5c85bda233b..a26c40ecb84 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -1429,6 +1429,7 @@ val DetectAndOptimizeForExpression : TcGlobals -> OptimizeForExpressionOptions - val TryEliminateDesugaredConstants : TcGlobals -> range -> Const -> Expr option +val MemberIsExplicitImpl : TcGlobals -> ValMemberInfo -> bool val ValIsExplicitImpl : TcGlobals -> Val -> bool val ValRefIsExplicitImpl : TcGlobals -> ValRef -> bool diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index e59a91b151f..da88752eb44 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -1305,7 +1305,7 @@ let CombineVisibilityAttribs vis1 vis2 m = errorR(Error(FSComp.SR.tcMultipleVisibilityAttributes(),m)) if Option.isSome vis1 then vis1 else vis2 -let ComputeAccessAndCompPath env declKindOpt m vis actualParent = +let ComputeAccessAndCompPath env declKindOpt m vis overrideVis actualParent = let accessPath = env.eAccessPath let accessModPermitted = match declKindOpt with @@ -1315,11 +1315,12 @@ let ComputeAccessAndCompPath env declKindOpt m vis actualParent = if Option.isSome vis && not accessModPermitted then errorR(Error(FSComp.SR.tcMultipleVisibilityAttributesWithLet(),m)) let vis = - match vis with - | None -> taccessPublic (* a module or member binding defaults to "public" *) - | Some SynAccess.Public -> taccessPublic - | Some SynAccess.Private -> taccessPrivate accessPath - | Some SynAccess.Internal -> taccessInternal + match overrideVis, vis with + | Some v,_ -> v + | _, None -> taccessPublic (* a module or member binding defaults to "public" *) + | _, Some SynAccess.Public -> taccessPublic + | _, Some SynAccess.Private -> taccessPrivate accessPath + | _, Some SynAccess.Internal -> taccessInternal let vis = match actualParent with @@ -1358,7 +1359,7 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i | _ -> false let isExtrinsic = (declKind=ExtrinsicExtensionBinding) - let actualParent = + let actualParent, overrideVis = // Use the parent of the member if it's available // If it's an extrinsic extension member or not a member then use the containing module. match memberInfoOpt with @@ -1366,10 +1367,20 @@ let MakeAndPublishVal cenv env (altActualParent,inSig,declKind,vrec,(ValScheme(i if memberInfo.ApparentParent.IsModuleOrNamespace then errorR(InternalError(FSComp.SR.tcExpectModuleOrNamespaceParent(id.idText),m)) - Parent(memberInfo.ApparentParent) - | _ -> altActualParent - - let vis,_ = ComputeAccessAndCompPath env (Some declKind) id.idRange vis actualParent + // Members of interface implementations have the accessibility of the interface + // they are implementing. + let vis = + if Tastops.MemberIsExplicitImpl cenv.g memberInfo then + let slotSig = List.head memberInfo.ImplementedSlotSigs + match slotSig.ImplementedType with + | TType_app (tyconref,_) -> Some tyconref.Accessibility + | _ -> None + else + None + Parent(memberInfo.ApparentParent), vis + | _ -> altActualParent, None + + let vis,_ = ComputeAccessAndCompPath env (Some declKind) id.idRange vis overrideVis actualParent let inlineFlag = if HasFSharpAttributeOpt cenv.g cenv.g.attrib_DllImportAttribute attrs then @@ -11575,7 +11586,7 @@ module TcRecdUnionAndEnumDeclarations = begin | Parent tcref -> combineAccess vis tcref.TypeReprAccessibility let MakeRecdFieldSpec _cenv env parent (isStatic,konst,ty',attrsForProperty,attrsForField,id,isMutable,vol,xmldoc,vis,m) = - let vis,_ = ComputeAccessAndCompPath env None m vis parent + let vis,_ = ComputeAccessAndCompPath env None m vis None parent let vis = CombineReprAccess parent vis NewRecdField isStatic konst id ty' isMutable vol attrsForProperty attrsForField xmldoc vis false @@ -11653,7 +11664,7 @@ module TcRecdUnionAndEnumDeclarations = begin let TcUnionCaseDecl cenv env parent thisTy tpenv (UnionCase (synAttrs,id,args,xmldoc,vis,m)) = let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs // the attributes of a union case decl get attached to the generated "static factory" method - let vis,_ = ComputeAccessAndCompPath env None m vis parent + let vis,_ = ComputeAccessAndCompPath env None m vis None parent let vis = CombineReprAccess parent vis let realUnionCaseName = if id.idText = opNameCons then "Cons" @@ -11703,7 +11714,7 @@ module TcRecdUnionAndEnumDeclarations = begin | SynConst.UserNum _ -> error(Error(FSComp.SR.tcInvalidEnumerationLiteral(),m)) | _ -> let v = TcConst cenv fieldTy m env v - let vis,_ = ComputeAccessAndCompPath env None m None parent + let vis,_ = ComputeAccessAndCompPath env None m None None parent let vis = CombineReprAccess parent vis if id.idText = "value__" then errorR(Error(FSComp.SR.tcNotValidEnumCaseName(),id.idRange)) NewRecdField true (Some v) id thisTy false false [] attrs (xmldoc.ToXmlDoc()) vis false @@ -13961,7 +13972,7 @@ module TcExceptionDeclarations = let TcExnDefnCore_Phase1A cenv env parent (SynExceptionDefnRepr(synAttrs,UnionCase(_,id,_,_,_,_),_,doc,vis,m)) = let attrs = TcAttributes cenv env AttributeTargets.ExnDecl synAttrs if not (String.isUpper id.idText) then errorR(NotUpperCaseConstructor(m)) - let vis,cpath = ComputeAccessAndCompPath env None m vis parent + let vis,cpath = ComputeAccessAndCompPath env None m vis None parent let vis = TcRecdUnionAndEnumDeclarations.CombineReprAccess parent vis CheckForDuplicateConcreteType env (id.idText + "Exception") id.idRange CheckForDuplicateConcreteType env id.idText id.idRange @@ -14203,7 +14214,7 @@ module EstablishTypeDefinitionCores = let modKind = ComputeModuleOrNamespaceKind cenv.g true typeNames modAttrs id.idText let modName = AdjustModuleName modKind id.idText - let vis,_ = ComputeAccessAndCompPath envInitial None id.idRange vis parent + let vis,_ = ComputeAccessAndCompPath envInitial None id.idRange vis None parent CheckForDuplicateModule envInitial id.idText id.idRange let id = ident (modName, id.idRange) @@ -14232,7 +14243,7 @@ module EstablishTypeDefinitionCores = // Augmentations of type definitions are allowed within the same file as long as no new type representation or abbreviation is given CheckForDuplicateConcreteType env id.idText id.idRange - let vis,cpath = ComputeAccessAndCompPath env None id.idRange synVis parent + let vis,cpath = ComputeAccessAndCompPath env None id.idRange synVis None parent // Establish the visibility of the representation, e.g. // type R = @@ -14249,7 +14260,7 @@ module EstablishTypeDefinitionCores = | SynTypeDefnSimpleRepr.Enum _ -> None | SynTypeDefnSimpleRepr.Exception _ -> None - let visOfRepr,_ = ComputeAccessAndCompPath env None id.idRange synVisOfRepr parent + let visOfRepr,_ = ComputeAccessAndCompPath env None id.idRange synVisOfRepr None parent let visOfRepr = combineAccess vis visOfRepr // If we supported nested types and modules then additions would be needed here let lmtyp = notlazy (NewEmptyModuleOrNamespaceType ModuleOrType) @@ -15955,7 +15966,7 @@ let rec TcSignatureElementNonMutRec cenv parent typeNames endm (env: TcEnv) synS return! TcSignatureElementsMutRec cenv parent endm None env [modDecl] else let id = ComputeModuleName longPath - let vis,_ = ComputeAccessAndCompPath env None im vis parent + let vis,_ = ComputeAccessAndCompPath env None im vis None parent let attribs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs CheckNamespaceModuleOrTypeName cenv.g id let modKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind cenv.g true typeNames attribs id.idText @@ -16274,7 +16285,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv:cenv) parent typeNames scopem let modName = EstablishTypeDefinitionCores.AdjustModuleName modKind id.idText CheckForDuplicateConcreteType env modName im CheckForDuplicateModule env id.idText id.idRange - let vis,_ = ComputeAccessAndCompPath env None id.idRange vis parent + let vis,_ = ComputeAccessAndCompPath env None id.idRange vis None parent let endm = m.EndRange let id = ident (modName, id.idRange) diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs new file mode 100644 index 00000000000..7942f93d265 --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs @@ -0,0 +1,13 @@ +type internal Foo() = class end + +type internal IMyInterface = + abstract member Method1 : Foo -> unit + +type Class1() = + interface IMyInterface with + // Bug: https://github.com/Microsoft/visualfsharp/issues/557 + // error FS0410: The type 'Foo' is less accessible than + // the value, member or type 'override Class1.Method1 : v:Foo -> unit' it is used in + // but should be fine because interface implementations are explicit and interface is + // internal too. + member this.Method1(v : Foo) = () \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst index c3adca2f28d..6da636e31d4 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst @@ -1,3 +1,4 @@ SOURCE=GenericMethodsOnInterface01.fs # GenericMethodsOnInterface01.fs SOURCE=GenericMethodsOnInterface02.fs # GenericMethodsOnInterface02.fs - SOURCE=ConcreteUnitOnInterface01.fs # ConcreteUnitOnInterface01.fs \ No newline at end of file + SOURCE=ConcreteUnitOnInterface01.fs # ConcreteUnitOnInterface01.fs + SOURCE=InternalInterfaceWithInternalArgument.fs \ No newline at end of file From 7a6be50632d748a4ed0606193ce63ce7d746c790 Mon Sep 17 00:00:00 2001 From: Kurt Schelfthout Date: Sat, 3 Dec 2016 22:03:20 +0000 Subject: [PATCH 2/3] Expand test and move to better place. --- .../InterfaceImplementationVisibility.fs | 84 +++++++++++++++++++ .../AccessibilityAnnotations/basic/env.lst | 4 +- .../InternalInterfaceWithInternalArgument.fs | 13 --- .../env.lst | 1 - 4 files changed, 87 insertions(+), 15 deletions(-) create mode 100644 tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/InterfaceImplementationVisibility.fs delete mode 100644 tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/InterfaceImplementationVisibility.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/InterfaceImplementationVisibility.fs new file mode 100644 index 00000000000..ec012d52f76 --- /dev/null +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/InterfaceImplementationVisibility.fs @@ -0,0 +1,84 @@ + +module Definitions = + + type private PrivateArg() = class end + + type internal InternalArg() = class end + + type PublicArg() = class end + + type private IPrivateInterface = + abstract A : PublicArg -> InternalArg + abstract B : PublicArg -> PrivateArg + abstract C : InternalArg -> PrivateArg + + type internal IInternalInterface = + abstract A : PublicArg -> InternalArg + + type IPublicInterface = + abstract A : PublicArg -> PublicArg + + // class accessibility should have no bearing on + // being able to implement any of these; as long + // as all the types are accessible at the implementation + // location the compiler need not complain. + + // this already worked in F# 4.0 + type private PrivateClass() = + interface IPrivateInterface with + member __.A _ = InternalArg() + member __.B _ = PrivateArg() + member __.C _ = PrivateArg() + interface IInternalInterface with + member __.A _ = InternalArg() + interface IPublicInterface with + member __.A _ = PublicArg() + + // these two did no work in F# 4.0. + type internal InternalClass() = + interface IPrivateInterface with + member __.A _ = InternalArg() + member __.B _ = PrivateArg() + member __.C _ = PrivateArg() + interface IInternalInterface with + member __.A _ = InternalArg() + interface IPublicInterface with + member __.A _ = PublicArg() + + type public PublicClass() = + interface IPrivateInterface with + member __.A _ = InternalArg() + member __.B _ = PrivateArg() + member __.C _ = PrivateArg() + interface IInternalInterface with + member __.A _ = InternalArg() + interface IPublicInterface with + member __.A _ = PublicArg() + + let private privateValue = PrivateClass() + let private privateValueAsPrivateInterface = privateValue :> IPrivateInterface + let internal privateValueAsInternalInterface = privateValue :> IInternalInterface + let privateValueAsPublicInterface = privateValue :> IPublicInterface + + let internal internalValue = InternalClass() + let private internalValueAsPrivateInterface = internalValue :> IPrivateInterface + let internal internalValueAsInternalInterface = internalValue :> IInternalInterface + let internalValueAsPublicInterface = internalValue :> IPublicInterface + + let publicValue = PublicClass() + let private publicValueAsPrivateInterface = publicValue :> IPrivateInterface + let internal publicValueAsInternalInterface = publicValue :> IInternalInterface + let publicValueAsPublicInterface = publicValue :> IPublicInterface + +module OtherModule = + open Definitions + + // internal and public is all you can see here; private interface are not visible. + + let internal internalValue = InternalClass() + let internal internalValueAsInternalInterface = internalValue :> IInternalInterface + let internalValueAsPublicInterface = internalValue :> IPublicInterface + + let publicValue = PublicClass() + let internal publicValueAsInternalInterface = publicValue :> IInternalInterface + let publicValueAsPublicInterface = publicValue :> IPublicInterface diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst index dbefd3823c0..2c55d190e44 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst @@ -19,4 +19,6 @@ SOURCE=E_ProtectedThingsInaccessible01.fs SCFLAGS="--test:ErrorRanges" # E_ProtectedThingsInaccessible01.fs SOURCE=E_MoreAccessibleBaseClass01.fs # E_MoreAccessibleBaseClass01.fs - SOURCE=E_MoreAccessibleBaseClass02.fs # E_MoreAccessibleBaseClass02.fs \ No newline at end of file + SOURCE=E_MoreAccessibleBaseClass02.fs # E_MoreAccessibleBaseClass02.fs + + SOURCE=InterfaceImplementationVisibility.fs \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs deleted file mode 100644 index 7942f93d265..00000000000 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/InternalInterfaceWithInternalArgument.fs +++ /dev/null @@ -1,13 +0,0 @@ -type internal Foo() = class end - -type internal IMyInterface = - abstract member Method1 : Foo -> unit - -type Class1() = - interface IMyInterface with - // Bug: https://github.com/Microsoft/visualfsharp/issues/557 - // error FS0410: The type 'Foo' is less accessible than - // the value, member or type 'override Class1.Method1 : v:Foo -> unit' it is used in - // but should be fine because interface implementations are explicit and interface is - // internal too. - member this.Method1(v : Foo) = () \ No newline at end of file diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst index 6da636e31d4..dab50c45e84 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/InterfaceSpecificationsAndImplementations/env.lst @@ -1,4 +1,3 @@ SOURCE=GenericMethodsOnInterface01.fs # GenericMethodsOnInterface01.fs SOURCE=GenericMethodsOnInterface02.fs # GenericMethodsOnInterface02.fs SOURCE=ConcreteUnitOnInterface01.fs # ConcreteUnitOnInterface01.fs - SOURCE=InternalInterfaceWithInternalArgument.fs \ No newline at end of file From 5890e08a1c775ffacae72760b15f524f95ae70fd Mon Sep 17 00:00:00 2001 From: Kurt Schelfthout Date: Sat, 3 Dec 2016 22:30:40 +0000 Subject: [PATCH 3/3] Small tweak so test name shows up. --- .../DeclarationElements/AccessibilityAnnotations/basic/env.lst | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst index 2c55d190e44..42ee4cb3de7 100644 --- a/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst +++ b/tests/fsharpqa/Source/Conformance/DeclarationElements/AccessibilityAnnotations/basic/env.lst @@ -21,4 +21,5 @@ SOURCE=E_MoreAccessibleBaseClass01.fs # E_MoreAccessibleBaseClass01.fs SOURCE=E_MoreAccessibleBaseClass02.fs # E_MoreAccessibleBaseClass02.fs - SOURCE=InterfaceImplementationVisibility.fs \ No newline at end of file + SOURCE=InterfaceImplementationVisibility.fs # InterfaceImplementationVisibility.fs + \ No newline at end of file