[WIP] sig data trim

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)))
 

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.

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<UnionCase>
+            }
+
+      /// 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)  
 

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

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<string,'a list>
 
     val empty: NameMultiMap<'T>