Commit 20e1c6cc authored by simonpj's avatar simonpj
Browse files

[project @ 2004-01-12 14:36:28 by simonpj]

Wibbles to exporting types abstractly
parent 0a095555
......@@ -945,7 +945,7 @@ eta_expand n us expr ty
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}
......
......@@ -58,6 +58,7 @@ import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv,
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 )
......@@ -399,7 +400,8 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
\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,
......@@ -435,7 +437,7 @@ tyThingToIfaceDecl _ _ ext (AClass clas)
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,
......@@ -474,7 +476,9 @@ tyThingToIfaceDecl _ discard_data_cons ext (ATyCon tycon)
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)
......
......@@ -183,12 +183,11 @@ import LoadIface ( readIface, loadInterface, ifaceInstGates )
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,
......@@ -210,6 +209,7 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc
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,
......@@ -264,11 +264,21 @@ mkIface hsc_env location maybe_old_iface
= 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
......@@ -328,11 +338,30 @@ mkIface hsc_env location maybe_old_iface
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)
......@@ -704,7 +733,7 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names
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
]
......@@ -720,7 +749,7 @@ mkIfaceExports exports
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)
......
......@@ -50,7 +50,7 @@ import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
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 )
......@@ -203,12 +203,28 @@ getThing name
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}
%************************************************************************
......
......@@ -28,7 +28,7 @@ module HscTypes (
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
implicitTyThings, isImplicitTyThing,
implicitTyThings,
TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
......@@ -74,7 +74,7 @@ import Module
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 )
......@@ -431,12 +431,6 @@ unQualInScope env
%************************************************************************
\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) = []
......
......@@ -68,7 +68,7 @@ import Panic (panic)
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 )
......
......@@ -470,7 +470,7 @@ tcRnThing hsc_env ictxt rdr_name
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
......
......@@ -531,6 +531,7 @@ splitRecNewType_maybe :: Type -> Maybe Type
-- 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 )
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment