X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FMkIface.lhs;h=39c3734bcb987084e63ca28d654e7679f4ef9e24;hb=20e1c6cc426dcc864c7fc5710b1b5aa25453061c;hp=e43b6dfa9e93a0669b84afc5a2af8bf1a986b029;hpb=3206cccbdb97d4b22e92915508dc12c11b3d4c60;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index e43b6df..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, @@ -201,14 +200,17 @@ import HscTypes ( ModIface(..), 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, @@ -227,6 +229,7 @@ import FastString import DATA_IOREF ( writeIORef ) import Monad ( when ) +import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, fromJust, expectJust ) \end{code} @@ -261,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 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 @@ -281,7 +294,7 @@ mkIface hsc_env location maybe_old_iface 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, @@ -326,6 +339,30 @@ mkIface hsc_env location maybe_old_iface 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) ----------------------------- @@ -693,40 +730,36 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names \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