diff --git a/src/fsharp/TypedTreeBasics.fs b/src/fsharp/TypedTreeBasics.fs index fe730b9aeb..5feb47a827 100644 --- a/src/fsharp/TypedTreeBasics.fs +++ b/src/fsharp/TypedTreeBasics.fs @@ -445,7 +445,14 @@ let canAccessFrom (TAccess x) cpath = x |> List.forall (fun cpath1 -> canAccessCompPathFrom cpath1 cpath) let canAccessFromEverywhere (TAccess x) = x.IsEmpty + let canAccessFromSomewhere (TAccess _) = true + +let hasInternalsVisibleToAttribute _ivts = false // TBD + +let canAccessFromSomewhereOutside ivts access = + canAccessFromEverywhere access || hasInternalsVisibleToAttribute ivts + let isLessAccessible (TAccess aa) (TAccess bb) = not (aa |> List.forall(fun a -> bb |> List.exists (fun b -> canAccessCompPathFrom a b))) diff --git a/src/fsharp/TypedTreeBasics.fsi b/src/fsharp/TypedTreeBasics.fsi index fd9fe751e9..eef9aa5c73 100644 --- a/src/fsharp/TypedTreeBasics.fsi +++ b/src/fsharp/TypedTreeBasics.fsi @@ -207,6 +207,8 @@ val canAccessFromEverywhere: Accessibility -> bool val canAccessFromSomewhere: Accessibility -> bool +val canAccessFromSomewhereOutside: 'T -> Accessibility -> bool + val isLessAccessible: Accessibility -> Accessibility -> bool /// Given (newPath, oldPath) replace oldPath by newPath in the TAccess. diff --git a/src/fsharp/TypedTreeOps.fs b/src/fsharp/TypedTreeOps.fs index 87dfcfdeb3..7fc83d9d5d 100644 --- a/src/fsharp/TypedTreeOps.fs +++ b/src/fsharp/TypedTreeOps.fs @@ -5264,6 +5264,11 @@ and remapParentRef tyenv p = | ParentNone -> ParentNone | Parent x -> Parent (x |> remapTyconRef tyenv.tyconRefRemap) +and filterImmediateValsAndTycons ft fv (x: ModuleOrNamespaceType) = + let vals = x.AllValsAndMembers |> QueueList.filter fv + let tycons = x.AllEntities |> QueueList.filter ft + ModuleOrNamespaceType(x.ModuleOrNamespaceKind, vals, tycons) + and mapImmediateValsAndTycons ft fv (x: ModuleOrNamespaceType) = let vals = x.AllValsAndMembers |> QueueList.map fv let tycons = x.AllEntities |> QueueList.map ft @@ -9046,26 +9051,58 @@ let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = allRemap //-------------------------------------------------------------------------- -// Apply a "local to nonlocal" renaming to a module type. This can't use -// remap_mspec since the remapping we want isn't to newly created nodes -// but rather to remap to the nonlocal references. This is deliberately -// "breaking" the binding structure implicit in the module type, which is -// the whole point - one things are rewritten to use non local references then -// the elements can be copied at will, e.g. when inlining during optimization. +// Apply a "local to nonlocal" renaming to a module type and restrict +// at the assembly boundary. //------------------------------------------------------------------------ - let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = - let tps', tmenvinner = tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv (d.entity_typars.Force(d.entity_range)) - let typarsR = LazyWithContext.NotLazy tps' - let attribsR = d.entity_attribs |> remapAttribs ctxt tmenvinner - let tyconReprR = d.entity_tycon_repr |> remapTyconRepr ctxt tmenvinner - let tyconAbbrevR = d.TypeAbbrev |> Option.map (remapType tmenvinner) - let tyconTcaugR = d.entity_tycon_tcaug |> remapTyconAug tmenvinner + let tps', tmenvinner = + tmenvCopyRemapAndBindTypars (remapAttribs ctxt tmenv) tmenv (d.entity_typars.Force(d.entity_range)) + + let typarsR = + // NOTE: existing checks enforce that everything involved in a typar is at + // least as accessible as the type definition. So no restricting is needed + // for typars. + LazyWithContext.NotLazy tps' + + let attribsR = + d.entity_attribs + |> List.filter (restrictAttrib ctxt) + |> remapAttribs ctxt tmenvinner + + let tyconReprR = + d.entity_tycon_repr + |> restrictTyconRepr ctxt d.TypeReprAccessibility + |> remapTyconRepr ctxt tmenvinner + + let tyconAbbrevR = + d.TypeAbbrev + // Turns out prior to F# 4.1 public abbreviations of private things could + // occur, a deprecation warning is now given, e.g. + // + // type private CPrivate() = class end + // + // type AbbreviationPublic = CPrivate + // + // TODO - in this case refuse to emit reference assemblies + |> Option.map (remapType tmenvinner) + + let tyconTcaugR = + d.entity_tycon_tcaug + |> restrictTyconAug ctxt + |> remapTyconAug tmenvinner + let modulContentsR = - MaybeLazy.Strict (d.entity_modul_contents.Value - |> mapImmediateValsAndTycons (remapTyconToNonLocal ctxt tmenv) (remapValToNonLocal ctxt tmenv)) - let exnInfoR = d.ExceptionInfo |> remapTyconExnInfo ctxt tmenvinner + d.entity_modul_contents.Value + |> restrictImmediateValsAndTycons ctxt + |> mapImmediateValsAndTycons (remapTyconToNonLocal ctxt tmenv) (remapValToNonLocal ctxt tmenv) + |> MaybeLazy.Strict + + let exnInfoR = + d.ExceptionInfo + |> restrictExnInfo ctxt + |> remapTyconExnInfo ctxt tmenvinner + { d with entity_typars = typarsR entity_attribs = attribsR @@ -9078,6 +9115,132 @@ let rec remapEntityDataToNonLocal ctxt tmenv (d: Entity) = Some { dd with entity_tycon_abbrev = tyconAbbrevR; entity_exn_info = exnInfoR } | _ -> None } +and restrictAttrib _ctxt _inp = true + // TODO: filter the attribute by structure, e.g. if any part of its specification is private + +and restrictExnInfo _ctxt inp = inp + // NOTE: existing checks enforce that the exception reprsentation is at least as + // acessible as the exception type, so there is nothing to do here. + +and restrictTyconAug ctxt (x: TyconAugmentation) = + { x with + tcaug_equals = + match x.tcaug_equals with + | None -> None + | Some (vref1, vref2) -> + if canAccessFromSomewhereOutside "TODO" vref1.Accessibility && + canAccessFromSomewhereOutside "TODO" vref2.Accessibility then + Some (vref1, vref2) + else + None + + tcaug_compare = + match x.tcaug_compare with + | None -> None + | Some (vref1, vref2) -> + if canAccessFromSomewhereOutside "TODO" vref1.Accessibility && + canAccessFromSomewhereOutside "TODO" vref2.Accessibility then + Some (vref1, vref2) + else + None + + tcaug_compare_withc = + match x.tcaug_compare_withc with + | None -> None + | Some vref -> + if canAccessFromSomewhereOutside "TODO" vref.Accessibility then + Some vref + else + None + + tcaug_hash_and_equals_withc = + match x.tcaug_hash_and_equals_withc with + | None -> None + | Some (vref1, vref2, vref3) -> + if canAccessFromSomewhereOutside "TODO" vref1.Accessibility && + canAccessFromSomewhereOutside "TODO" vref2.Accessibility && + canAccessFromSomewhereOutside "TODO" vref3.Accessibility then + Some (vref1, vref2, vref3) + else + None + + tcaug_adhoc = + x.tcaug_adhoc + |> NameMultiMap.filterRange (fun vref -> canAccessFromSomewhereOutside "TODO" vref.Accessibility) + + tcaug_adhoc_list = + x.tcaug_adhoc_list + |> ResizeArray.filter (fun (_flag, vref) -> canAccessFromSomewhereOutside "TODO" vref.Accessibility) + + // Note, existing checks enforce that the base type is always as accessible as the type + // so no filtering needed for tcaug_super + //tcaug_interfaces = + // x.tcaug_interfaces + // |> List.filter (restrictInterface ctxt) + } + +//and restrictInterface _ctxt (_ityp, _, _) = +// // TODO: check that ityp is at least as accessible as the enclosing type +// true + +and restrictTyconRepr ctxt reprAccess repr = + match repr with + | TFSharpObjectRepr data -> + TFSharpObjectRepr + { data with + /// The declared abstract slots of the class, interface or struct + fsobjmodel_vslots = data.fsobjmodel_vslots |> List.filter (fun vref -> canAccessFromSomewhereOutside "TODO" vref.Accessibility) + + /// The fields of the class, struct or enum + fsobjmodel_rfields = data.fsobjmodel_rfields |> restrictRecordFields ctxt reprAccess + } + + | TFSharpRecdRepr flds -> + TFSharpRecdRepr (flds |> restrictRecordFields ctxt reprAccess) + + | TFSharpUnionRepr unionData -> + if canAccessFromSomewhereOutside "TODO" reprAccess then + repr + else + TNoRepr + + | TILObjectRepr _ -> failwith "TODO" + | TAsmRepr _ -> failwith "TODO" + | TMeasureableRepr typ -> failwith "TODO" +#if !NO_EXTENSIONTYPING + | TProvidedTypeRepr _info -> failwith "TODO" + | TProvidedNamespaceRepr (env, typs) -> failwith "TODO" +#endif + | TNoRepr -> TNoRepr + //if canAccessFromSomewhereOutside "TODO" reprAccess then + // repr + //else TyconReprNone + +and restrictRecordFields _ctxt _reprAccess fields = + { + FieldsByIndex = fields.FieldsByIndex |> Array.filter (fun fld -> canAccessFromSomewhereOutside "TODO" fld.Accessibility) + FieldsByName = fields.FieldsByName |> NameMap.filterRange (fun fld -> canAccessFromSomewhereOutside "TODO" fld.Accessibility) + } + +and restrictUnionData _ctxt _reprAccess unionData = + { + /// The cases contained in the discriminated union. + CasesTable = + { + CasesByIndex = unionData.CasesTable.CasesByIndex |> + CasesByName: NameMap + } + + /// The ILX data structure representing the discriminated union. + CompiledRepresentation: IlxUnionRef cache + } + +and restrictImmediateValsAndTycons _ctxt mty = + filterImmediateValsAndTycons + (fun tycon -> canAccessFromSomewhereOutside "TODO" tycon.Accessibility) + (fun vspec -> canAccessFromSomewhereOutside "TODO" vspec.Accessibility) + mty + and remapTyconToNonLocal ctxt tmenv x = x |> Construct.NewModifiedTycon (remapEntityDataToNonLocal ctxt tmenv) diff --git a/src/fsharp/absil/illib.fs b/src/fsharp/absil/illib.fs index dcc7d133ff..c648811744 100644 --- a/src/fsharp/absil/illib.fs +++ b/src/fsharp/absil/illib.fs @@ -1100,6 +1100,13 @@ module NameMultiMap = let chooseRange f (m: NameMultiMap<'T>) = Map.foldBack (fun _ x sofar -> List.choose f x @ sofar) m [] + let filterRange (f: 'T -> bool) (m: NameMultiMap<'T>) : NameMultiMap<'T> = + m + // Filter all the entries for each key + |> Map.map (fun _ l -> List.filter f l) + // Remove the empty entries + |> Map.filter (fun _ l -> not (List.isEmpty l)) + let map f (m: NameMultiMap<'T>) = NameMap.map (List.map f) m let empty : NameMultiMap<'T> = Map.empty diff --git a/src/fsharp/absil/illib.fsi b/src/fsharp/absil/illib.fsi index da8bc23da1..dfbabca9c4 100644 --- a/src/fsharp/absil/illib.fsi +++ b/src/fsharp/absil/illib.fsi @@ -566,6 +566,8 @@ module internal NameMultiMap = val chooseRange: f:('T -> 'a option) -> m:NameMultiMap<'T> -> 'a list + val filterRange: f:('T -> bool) -> m:NameMultiMap<'T> -> NameMultiMap<'T> + val map: f:('T -> 'a) -> m:NameMultiMap<'T> -> Map val empty: NameMultiMap<'T> diff --git a/tests/fsharp/new.fs b/tests/fsharp/new.fs new file mode 100644 index 0000000000..bf72de20e3 --- /dev/null +++ b/tests/fsharp/new.fs @@ -0,0 +1,171 @@ +module M + +type ClassPublic() = class end + +type private ClassPrivate() = // CUT + static member ClassPrivateProperty = 1 // CUT + +type InterfacePublic = interface end + +type private InterfacePrivate = interface end + +// Val +let private PrivateFunction() = 0xabba // CUT + + +// +// type GenericClass<'T when 'T :> InterfacePrivate >() = // NOTE: This is not allowed +// class end + + +[] +type PublicAttribute () = + inherit Attribute() + +[] +type private PrivateAttribute () = + inherit Attribute() + +[] +type PublicWithInternalConstructorAttribute internal () = + inherit Attribute() + +[] +type PublicWithInternalSetterPropertyAttribute() = + inherit Attribute() + member val internal Prop1 : int = 0 with get, set + +[] // KEEP +[] // note: this is allowed! accessibility of attributes is implied by structure of attribute! CUT +[] // note: this is allowed! accessibility of attributes is implied by structure of attribute! CUT +[] // note: this is allowed! accessibility of attributes is implied by structure of attribute! CUT +type ClassPublicWithPrivateAttributes() = class end + +type ClassPublicWithPrivateInterface() = + interface InterfacePrivate + static member MPublic1() = 1 + static member private MPrivate1() = ClassPublic() // CUT + static member private MPrivate2() = ClassPrivate() // CUT + +type private InterfacePrivateInheritingInterfacePublic = + interface + inherit InterfacePublic + end + +type ClassPublicWithPrivateInterface() = + interface InterfacePrivateInheritingInterfacePublic + // TODO: note, restriction should not cut this fully, but rather reduce it to + // to InterfacePrivateInheritingInterfacePublic + // Question: What does C# do here, e.g. + // - internal interface extends a public interface + // - a public class implements this interface + // - what ends up in the reference assembly? + + + +type private ClassPrivateUsedInPrivateFieldOfPublicStruct = // This must be kept! + member private x.P = 1 + +[] +type private StructPrivateUsedInPrivateFieldOfPublicStruct = // This must be kept! + val private X: int // This must be kept! Computation of "has default value" and "unmanaged" depend on this! + +[] +type S = + val private X1: ClassPrivateUsedInPrivateFieldOfPublicStruct + val private X2: StructPrivateUsedInPrivateFieldOfPublicStruct + + + +type RecordPublic = + { FPublic: ClassPublic } + +type RecordPublicPrivate = // CUT + private { FRecordPublicPrivate: ClassPrivate } // CUT + +type private RecordPrivate = // CUT + { FRecordPrivate: ClassPrivate() } // CUT + +[] +type StructRecordPublic = + { FStructRecordPublic: ClassPublic() } + +[] +type StructRecordPublicPrivate = + private { FStructRecordPublicPrivate: ClassPrivate() } // CUT + +[] +type private StructRecordPrivate = // CUT + { FStructRecordPrivate: ClassPrivate() } // CUT + +type UnionPublic = + | UnionPublicCase1 of ClassPublic + | UnionPublicCase2 of ClassPublic + +type UnionPublicPrivate = + private // CUT + | UnionPublicPrivateCase1 of ClassPrivate // CUT + | UnionPublicPrivateCase2 of ClassPrivate // CUT + +type private UnionPrivate = // CUT + | UnionPrivateCase1 of ClassPrivate // CUT + | UnionPrivateCase2 of ClassPrivate // CUT + +[] +type StructUnionPublic = + | StructUnionPublicCase1 of ClassPublic + +[] +type StructUnionPublicPrivate = + private // CUT + | StructUnionPublicPrivateCase1 of ClassPrivate // CUT + +[] +type private StructUnionPrivate = // CUT + | StructUnionPrivateCase1 of ClassPrivate // CUT + +type private InterfacePrivate = + interface + abstract M: int -> int + end + +type GenericInterfacePublic<'T> = + interface + abstract M: int -> int + end + +type ClassPublicImplementingPrivateInterface() = + interface InterfacePrivate with // allowed, must be trimmed + member _.M(x:int) = x + interface GenericInterfacePublic with // allowed, must be trimmed + member _.M(x:int) = x + +// type private BaseClassPrivate() = +// class +// end +// type ClassPublicWithPrivateBaseClass() = +// inherit BaseClassPrivate() // not allowed + + +exception ExceptionPublic of ClassPublic +exception ExceptionAbbrevPublic = ExceptionPublic + +// Note, existing checks disallow this, for no good reason +//exception private ExceptionPrivate of ClassPrivate // Trimmed +exception private ExceptionPrivate of int // CUT! +exception private ExceptionAbbrevPrivate = ExceptionPrivate // CUT! + +// Implied private +module private ModulePrivate = + type CImplicitlyPrivate() = class end // CUT + // + duplicate out all of the above + + + + +let test1() = PrivateFunction() + +let test2() = C() |> ignore + +let test3() = C.P +