case splitRecNewType_maybe ty of {
Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
- Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
+ Nothing -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
}}}
\end{code}
lookupOccEnv, extendOccEnv, emptyOccEnv,
OccSet, unionOccSets, unitOccSet )
import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName )
+import NameSet ( NameSet, elemNameSet )
import Module ( ModuleName )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
\begin{code}
-tyThingToIfaceDecl :: Bool -> (TyCon -> Bool)
+tyThingToIfaceDecl :: Bool
+ -> NameSet -- Tycons and classes to export abstractly
-> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
tyThingToIfaceDecl discard_id_info _ ext (AnId id)
= IfaceId { ifName = getOccName id,
toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
-tyThingToIfaceDecl _ discard_data_cons ext (ATyCon tycon)
+tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
new_or_data | isNewTyCon tycon = NewType
| otherwise = DataType
- ifaceConDecls _ | discard_data_cons tycon = Unknown
+ abstract = getName tycon `elemNameSet` abstract_tcs
+
+ ifaceConDecls _ | abstract = Unknown
ifaceConDecls Unknown = Unknown
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
import BasicTypes ( Version, initialVersion, bumpVersion )
import TcRnMonad
import TcRnTypes ( ImportAvails(..), mkModDeps )
-import HscTypes ( ModIface(..),
+import HscTypes ( ModIface(..), TyThing(..),
ModGuts(..), ModGuts, IfaceExport,
GhciMode(..),
HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
- isImplicitTyThing,
mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache,
typeEnvElts,
Avails, AvailInfo, GenAvailInfo(..), availName,
isEmptyOccSet, intersectOccSet, intersectsOccSet,
occNameFS, isTcOcc )
import TyCon ( visibleDataCons, tyConDataCons )
+import Class ( classSelIds )
import DataCon ( dataConName )
import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule,
ModLocation(..), mkSysModuleNameFS, moduleUserString,
= do { eps <- hscEPS hsc_env
; let { this_mod_name = moduleName this_mod
; ext_nm = mkExtNameFn hsc_env eps this_mod_name
- ; decls = [ tyThingToIfaceDecl omit_prags omit_data_cons ext_nm thing
- | thing <- typeEnvElts type_env
- , not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ]
+ ; local_things = [thing | thing <- typeEnvElts type_env,
+ not (isWiredInName (getName thing)) ]
+ -- Do not export anything about wired-in things
+ -- (GHC knows about them already)
+
+ ; abstract_tcs :: NameSet -- TyCons and Classes whose representation is not exposed
+ ; abstract_tcs
+ | not omit_prags = emptyNameSet -- In the -O case, nothing is abstract
+ | otherwise = mkNameSet [ getName thing
+ | thing <- local_things
+ , isAbstractThing exports thing]
+
+ ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm thing
+ | thing <- local_things, wantDeclFor exports abstract_tcs thing ]
-- Don't put implicit Ids and class tycons in the interface file
- -- Nor wired-in things (GHC knows about them already)
; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env]
; deprecs = mkIfaceDeprec src_deprecs
ghci_mode = hsc_mode hsc_env
hi_file_path = ml_hi_file location
omit_prags = dopt Opt_OmitInterfacePragmas dflags
- omit_data_cons tycon -- Don't expose data constructors if none are
- -- exported and we are not optimising (i.e. not omit_prags)
- | omit_prags = not (any exported_data_con (tyConDataCons tycon))
- | otherwise = False
+
+
+isAbstractThing :: NameSet -> TyThing -> Bool
+isAbstractThing exports (ATyCon tc) = not (any exported_data_con (tyConDataCons tc))
+ where -- Don't expose rep if no datacons are exported
exported_data_con con = dataConName con `elemNameSet` exports
+
+isAbstractThing exports (AClass cls) = not (any exported_class_op (classSelIds cls))
+ where -- Don't expose rep if no classs op is exported
+ exported_class_op op = getName op `elemNameSet` exports
+
+isAbstractThing exports other = False
+
+wantDeclFor :: NameSet -- User-exported things
+ -> NameSet -- Abstract things
+ -> TyThing -> Bool
+wantDeclFor exports abstracts thing
+ | Just parent <- nameParent_maybe name -- An implicit thing
+ = parent `elemNameSet` abstracts && name `elemNameSet` exports
+ | otherwise
+ = True
+ where
+ name = getName thing
+
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-mkIfaceExports exports
+mkIfaceExports exports
= [ (mkSysModuleNameFS fs, eltsFM avails)
| (fs, avails) <- fmToList groupFM
]
occ = nameOccName name
occ_fs = occNameFS occ
mod_fs = moduleNameFS (nameModuleName name)
- avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
+ avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
| isTcOcc occ = AvailTC occ [occ]
| otherwise = Avail occ
avail_fs = occNameFS (availName avail)
import TysWiredIn ( tupleCon )
import Var ( TyVar, mkTyVar, tyVarKind )
import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
- isWiredInName, wiredInNameTyThing_maybe, nameParent )
+ isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe )
import NameEnv
import OccName ( OccName )
import Module ( Module, ModuleName, moduleName )
selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl)
-- Use nameParent to get the parent name of the thing
selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name
- = case lookupNameEnv decls_map main_name of
+ = case lookupNameEnv decls_map name of {
+ -- This first lookup will usually fail for subordinate names, because
+ -- the relevant decl is the parent decl.
+ -- But, if we export a data type decl abstractly, its selectors
+ -- get separate type signatures in the interface file
+ Just decl -> let
+ decls' = delFromNameEnv decls_map name
+ in
+ (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
+
+ Nothing ->
+ case nameParent_maybe name of {
+ Nothing -> (eps, Nothing ) ; -- No "parent"
+ Just main_name -> -- Has a parent; try that
+
+ case lookupNameEnv decls_map main_name of {
+ Just decl -> let
+ decls' = delFromNameEnv decls_map main_name
+ in
+ (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl) ;
Nothing -> (eps, Nothing)
- Just decl -> (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl)
- where
- main_name = nameParent name
- decls' = delFromNameEnv decls_map main_name
+ }}}
\end{code}
%************************************************************************
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
- implicitTyThings, isImplicitTyThing,
+ implicitTyThings,
TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
import InstEnv ( InstEnv, DFunId )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
-import Id ( Id, isImplicitId )
+import Id ( Id )
import Type ( TyThing(..) )
import Class ( Class, classSelIds, classTyCon )
%************************************************************************
\begin{code}
-isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon dc) = True
-isImplicitTyThing (AnId id) = isImplicitId id
-isImplicitTyThing (ATyCon tc) = isClassTyCon tc
-isImplicitTyThing other = False
-
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId id) = []
import Outputable (Outputable(ppr), pprPanic)
import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply)
import OccName (UserFS)
-import Var (Var(..))
+import Var (Var, idType)
import Id (Id, mkSysLocal)
import Name (Name)
import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems )
toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True {- Discard IdInfo -} (const False) {- Show data cons -}
+ = tyThingToIfaceDecl True {- Discard IdInfo -} emptyNameSet {- Show data cons -}
ext_nm thing
where
unqual = icPrintUnqual ictxt
-- Sometimes we want to look through a recursive newtype, and that's what happens here
-- Only applied to types of kind *, hence the newtype is always saturated
splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty
+splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p)
splitRecNewType_maybe (NewTcApp tc tys)
| isRecursiveTyCon tc
= ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc )
projects / ghc-hetmet.git / commitdiff