-- introduced by the type checker.
is_exported :: Name -> Bool
is_exported | ghci_mode == Interactive = isExternalName
- | otherwise = (`elemNameSet` export_fvs)
-
- export_fvs = availsToNameSet exports
+ | otherwise = (`elemNameSet` exports)
ppr_ds_rules [] = empty
ppr_ds_rules rules
import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
arityInfo, cafInfo, newStrictnessInfo,
workerInfo, unfoldingInfo, inlinePragInfo )
-import TyCon ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
+import TyCon ( TyCon, ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon,
isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
isTupleTyCon, tupleTyConBoxity,
tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn,
\begin{code}
-tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
-tyThingToIfaceDecl discard_prags ext (AnId id)
+tyThingToIfaceDecl :: Bool -> (TyCon -> Bool)
+ -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl
+tyThingToIfaceDecl discard_id_info _ ext (AnId id)
= IfaceId { ifName = getOccName id,
ifType = toIfaceType ext (idType id),
ifIdInfo = info }
where
- info | discard_prags = NoInfo
- | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
+ info | discard_id_info = NoInfo
+ | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id))
-tyThingToIfaceDecl _ ext (AClass clas)
+tyThingToIfaceDecl _ _ ext (AClass clas)
= IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
ifName = getOccName clas,
ifTyVars = toIfaceTvBndrs clas_tyvars,
toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
-tyThingToIfaceDecl _ ext (ATyCon tycon)
+tyThingToIfaceDecl _ discard_data_cons ext (ATyCon tycon)
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
new_or_data | isNewTyCon tycon = NewType
| otherwise = DataType
+ ifaceConDecls _ | discard_data_cons tycon = Unknown
ifaceConDecls Unknown = Unknown
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
-- This case only happens in the call to ifaceThing in InteractiveUI
-- Otherwise DataCons are filtered out in ifaceThing_acc
-tyThingToIfaceDecl _ ext (ADataCon dc)
+tyThingToIfaceDecl _ _ ext (ADataCon dc)
= IfaceId { ifName = getOccName dc,
ifType = toIfaceType ext full_ty,
ifIdInfo = NoInfo }
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 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
+ ; decls = [ tyThingToIfaceDecl omit_prags omit_data_cons ext_nm thing
| thing <- typeEnvElts type_env
, not (isImplicitTyThing thing) && not (isWiredInName (getName thing)) ]
-- Don't put implicit Ids and class tycons in the interface file
mi_boot = False,
mi_deps = deps,
mi_usages = usages,
- mi_exports = groupAvails exports,
+ mi_exports = mkIfaceExports exports,
mi_insts = iface_insts,
mi_rules = iface_rules,
mi_fixities = fixities,
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
+ exported_data_con con = dataConName con `elemNameSet` exports
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
\end{code}
\begin{code}
-groupAvails :: Avails -> [(ModuleName, [GenAvailInfo OccName])]
+mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
-- This keeps the list in canonical order
-groupAvails 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
data ModGuts
= ModGuts {
mg_module :: !Module,
- mg_exports :: !Avails, -- What it exports
+ mg_exports :: !NameSet, -- What it exports
mg_deps :: !Dependencies, -- What is below it, directly or otherwise
mg_dir_imps :: ![Module], -- Directly-imported modules; used to
-- generate initialisation code
-- the main worker function in exportsFromAvail
= ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
- AvailEnv) -- The accumulated exported stuff, kept in an env
- -- so we can common-up related AvailInfos
-emptyExportAccum = ([], emptyOccEnv, emptyAvailEnv)
+ NameSet) -- The accumulated exported stuff
+emptyExportAccum = ([], emptyOccEnv, emptyNameSet)
type ExportOccMap = OccEnv (Name, IE RdrName)
-- Tracks what a particular exported OccName
exportsFromAvail :: Bool -- False => no 'module M(..) where' header at all
-> Maybe [Located (IE RdrName)] -- Nothing => no explicit export list
- -> RnM Avails
+ -> RnM NameSet
-- Complains if two distinct exports have same OccName
-- Warns about identical exports.
-- Complains about exports items not in scope
exports_from_avail real_exports rdr_env imports }
-exports_from_avail Nothing rdr_env
- imports@(ImportAvails { imp_env = entity_avail_env })
+exports_from_avail Nothing rdr_env imports
= -- Export all locally-defined things
-- We do this by filtering the global RdrEnv,
- -- keeping only things that are (a) qualified,
- -- (b) locally defined, (c) a 'main' name
- -- Then we look up in the entity-avail-env
- return [ lookupAvailEnv entity_avail_env name
- | gre <- globalRdrEnvElts rdr_env,
- isLocalGRE gre,
- let name = gre_name gre,
- isNothing (nameParent_maybe name) -- Main things only
- ]
+ -- keeping only things that are locally-defined
+ return (mkNameSet [ gre_name gre
+ | gre <- globalRdrEnvElts rdr_env,
+ isLocalGRE gre ])
exports_from_avail (Just export_items) rdr_env
(ImportAvails { imp_qual = mod_avail_env,
imp_env = entity_avail_env })
= foldlM (exports_from_litem) emptyExportAccum
- export_items `thenM` \ (_, _, export_avail_map) ->
- returnM (nameEnvElts export_avail_map)
+ export_items `thenM` \ (_, _, exports) ->
+ returnM exports
where
exports_from_litem :: ExportAccum -> Located (IE RdrName) -> RnM ExportAccum
exports_from_litem acc = addLocM (exports_from_item acc)
exports_from_item :: ExportAccum -> IE RdrName -> RnM ExportAccum
- exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod)
+ exports_from_item acc@(mods, occs, exports) ie@(IEModuleContents mod)
| mod `elem` mods -- Duplicate export of M
= do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ;
warnIf warn_dup_exports (dupModuleExport mod) ;
Just avail_env
-> let
- mod_avails = [ filtered_avail
- | avail <- availEnvElts avail_env,
- let mb_avail = filter_unqual rdr_env avail,
- isJust mb_avail,
- let Just filtered_avail = mb_avail]
-
- avails' = foldl addAvail avails mod_avails
+ new_exports = [ name | avail <- availEnvElts avail_env,
+ name <- availNames avail,
+ inScopeUnqual rdr_env name ]
in
+
-- This check_occs not only finds conflicts between this item
-- and others, but also internally within this item. That is,
-- if 'M.x' is in scope in several ways, we'll have several
-- members of mod_avails with the same OccName.
+ check_occs ie occs new_exports `thenM` \ occs' ->
+ returnM (mod:mods, occs', addListToNameSet exports new_exports)
- foldlM (check_occs ie) occs mod_avails `thenM` \ occs' ->
- returnM (mod:mods, occs', avails')
-
- exports_from_item acc@(mods, occs, avails) ie
+ exports_from_item acc@(mods, occs, exports) ie
= lookupGlobalOccRn (ieName ie) `thenM` \ name ->
if isUnboundName name then
returnM acc -- Avoid error cascade
Just export_avail ->
-- Phew! It's OK! Now to check the occurrence stuff!
- checkForDodgyExport ie avail `thenM_`
- check_occs ie occs export_avail `thenM` \ occs' ->
- returnM (mods, occs', addAvail avails export_avail)
+
+ let
+ new_exports = availNames export_avail
+ in
+ checkForDodgyExport ie new_exports `thenM_`
+ check_occs ie occs new_exports `thenM` \ occs' ->
+ returnM (mods, occs', addListToNameSet exports new_exports)
}
-------------------------------
-filter_unqual :: GlobalRdrEnv -> AvailInfo -> Maybe AvailInfo
--- Filter the Avail by what's in scope unqualified
-filter_unqual env (Avail n)
- | in_scope env n = Just (Avail n)
- | otherwise = Nothing
-filter_unqual env (AvailTC n ns)
- | not (null ns') = Just (AvailTC n ns')
- | otherwise = Nothing
- where
- ns' = filter (in_scope env) ns
-
-in_scope :: GlobalRdrEnv -> Name -> Bool
+inScopeUnqual :: GlobalRdrEnv -> Name -> Bool
-- Checks whether the Name is in scope unqualified,
-- regardless of whether it's ambiguous or not
-in_scope env n = any unQualOK (lookupGRE_Name env n)
+inScopeUnqual env n = any unQualOK (lookupGRE_Name env n)
-------------------------------
-checkForDodgyExport :: IE RdrName -> AvailInfo -> RnM ()
-checkForDodgyExport (IEThingAll tc) (AvailTC _ [n]) = addWarn (dodgyExportWarn tc)
+checkForDodgyExport :: IE RdrName -> [Name] -> RnM ()
+checkForDodgyExport (IEThingAll tc) [n] = addWarn (dodgyExportWarn tc)
-- This occurs when you import T(..), but
-- only export T abstractly. The single [n]
-- in the AvailTC is the type or class itself
checkForDodgyExport _ _ = return ()
-------------------------------
-check_occs :: IE RdrName -> ExportOccMap -> AvailInfo -> RnM ExportOccMap
-check_occs ie occs avail
- = foldlM check occs (availNames avail)
+check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap
+check_occs ie occs names
+ = foldlM check occs names
where
check occs name
= case lookupOccEnv occs name_occ of
reportDeprecations tcg_env ;
-- Process the export list
- export_avails <- exportsFromAvail (isJust maybe_mod) exports ;
+ exports <- exportsFromAvail (isJust maybe_mod) exports ;
+{- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
-- Get any supporting decls for the exports that have not already
-- been sucked in for the declarations in the body of the module.
-- (This can happen if something is imported only to be re-exported.)
-- We don't need the results, but sucking them in may side-effect
-- the ExternalPackageState, apart from recording usage
mappM (tcLookupGlobal . availName) export_avails ;
+-}
-- Check whether the entire module is deprecated
-- This happens only once per module
let { mod_deprecs = checkModDeprec mod_deprec } ;
-- Add exports and deprecations to envt
- let { export_fvs = availsToNameSet export_avails ;
- final_env = tcg_env { tcg_exports = export_avails,
- tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs,
+ let { final_env = tcg_env { tcg_exports = exports,
+ tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
mod_deprecs }
-- A module deprecation over-rides the earlier ones
toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
toIfaceDecl ictxt thing
- = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing
+ = tyThingToIfaceDecl True {- Discard IdInfo -} (const False) {- Show data cons -}
+ ext_nm thing
where
unqual = icPrintUnqual ictxt
ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
-- Wrap up
let {
bndrs = bindersOfBinds core_binds ;
- my_exports = map (Avail . idName) bndrs ;
+ my_exports = mkNameSet (map idName bndrs) ;
-- ToDo: export the data types also?
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
tcg_type_env_var = type_env_var,
tcg_inst_env = mkImpInstEnv hsc_env,
tcg_inst_uses = dfuns_var,
- tcg_exports = [],
+ tcg_exports = emptyNameSet,
tcg_imports = init_imports,
tcg_dus = emptyDUs,
tcg_binds = emptyBag,
-- accumulated, but never consulted until the end.
-- Nevertheless, it's convenient to accumulate them along
-- with the rest of the info from this module.
- tcg_exports :: Avails, -- What is exported
+ tcg_exports :: NameSet, -- What is exported
tcg_imports :: ImportAvails, -- Information about what was imported
-- from where, including things bound
-- in this module