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,
import CmdLineOpts
import Name ( Name, nameModule, nameOccName, nameParent, isExternalName,
- nameParent_maybe, isWiredInName, NamedThing(..) )
+ nameParent_maybe, isWiredInName, NamedThing(..), nameModuleName )
import NameEnv
import NameSet
import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C,
OccSet, emptyOccSet, elemOccSet, occSetElts,
extendOccSet, extendOccSetList,
- isEmptyOccSet, intersectOccSet, intersectsOccSet )
-import TyCon ( visibleDataCons )
+ 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,
ModuleEnv, emptyModuleEnv, lookupModuleEnv,
import DATA_IOREF ( writeIORef )
import Monad ( when )
+import List ( insert )
import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust )
\end{code}
= 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 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
mi_boot = False,
mi_deps = deps,
mi_usages = usages,
- mi_exports = groupAvails this_mod exports,
+ mi_exports = mkIfaceExports exports,
mi_insts = iface_insts,
mi_rules = iface_rules,
mi_fixities = fixities,
hi_file_path = ml_hi_file location
omit_prags = dopt Opt_OmitInterfacePragmas dflags
+
+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)
-----------------------------
\end{code}
\begin{code}
-groupAvails :: Module -> Avails -> [(ModuleName, [GenAvailInfo OccName])]
+mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-groupAvails this_mod avails
- = [ (mkSysModuleNameFS fs, sortLt lt avails)
- | (fs,avails) <- fmToList groupFM
+mkIfaceExports exports
+ = [ (mkSysModuleNameFS fs, eltsFM avails)
+ | (fs, avails) <- fmToList groupFM
]
where
- groupFM :: FiniteMap FastString [GenAvailInfo OccName]
+ groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName))
-- Deliberately use the FastString so we
-- get a canonical ordering
- groupFM = foldl add emptyFM avails
+ groupFM = foldl add emptyFM (nameSetToList exports)
- add env avail = addToFM_C (\old _ -> avail':old) env mod_fs [avail']
- where
- mod_fs = moduleNameFS (moduleName avail_mod)
- avail_mod = nameModule (availName avail)
- avail' = sortAvail avail
-
- a1 `lt` a2 = availName a1 < availName a2
-
-sortAvail :: AvailInfo -> GenAvailInfo OccName
--- Convert to OccName, and sort the sub-names into canonical order
--- The canonical order has the "main name" at the beginning
--- (if it's there at all)
-sortAvail (Avail n) = Avail (nameOccName n)
-sortAvail (AvailTC n ns)
- | n `elem` ns = AvailTC occ (occ : mk_occs (filter (/= n) ns))
- | otherwise = AvailTC occ ( mk_occs ns)
- where
- occ = nameOccName n
- mk_occs ns = sortLt (<) (map nameOccName ns)
+ add env name = addToFM_C add_avail env mod_fs
+ (unitFM avail_fs avail)
+ where
+ occ = nameOccName name
+ occ_fs = occNameFS occ
+ mod_fs = moduleNameFS (nameModuleName name)
+ avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ]
+ | isTcOcc occ = AvailTC occ [occ]
+ | otherwise = Avail occ
+ avail_fs = occNameFS (availName avail)
+ add_avail avail_fm _ = addToFM_C add_item avail_fm avail_fs avail
+
+ add_item (AvailTC p occs) _ = AvailTC p (insert occ occs)
+ add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name)
\end{code}
+
%************************************************************************
%* *
Load the old interface file for this module (unless
projects / ghc-hetmet.git / blobdiff