From 20e1c6cc426dcc864c7fc5710b1b5aa25453061c Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 12 Jan 2004 14:36:31 +0000 Subject: [PATCH] [project @ 2004-01-12 14:36:28 by simonpj] Wibbles to exporting types abstractly --- ghc/compiler/coreSyn/CoreUtils.lhs | 2 +- ghc/compiler/iface/IfaceSyn.lhs | 10 ++++-- ghc/compiler/iface/MkIface.lhs | 53 ++++++++++++++++++++++++------- ghc/compiler/iface/TcIface.lhs | 28 ++++++++++++---- ghc/compiler/main/HscTypes.lhs | 10 ++---- ghc/compiler/ndpFlatten/FlattenMonad.hs | 2 +- ghc/compiler/typecheck/TcRnDriver.lhs | 2 +- ghc/compiler/types/Type.lhs | 1 + 8 files changed, 76 insertions(+), 32 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 5111730..8e53bbc 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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} diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 12fd982..f384013 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -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) diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index f577371..39c3734 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -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) diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 1d2d941..57c40de 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -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} %************************************************************************ diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5fd475c..b35e096 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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) = [] diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index cbdc206..944d10a 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -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 ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 295c15e..227d572 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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 diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 5cf242c..8104513 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -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 ) -- 1.7.10.4