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

Wibbles to exporting types abstractly

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}
 

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)
 

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)	    

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}
 
 %************************************************************************

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)   = []
 

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 )

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

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 )