import HsSyn ( HsModule(..), HsDecl(..), TyClDecl(..),
IE(..), ieName,
- ForeignDecl(..), ForKind(..), isDynamic,
+ ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), Sig(..), ImportDecl(..),
collectTopBinders
)
import PrelInfo ( main_RDR )
import UniqFM ( lookupUFM )
import Bag ( bagToList )
-import Maybes ( maybeToBool )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
isLocallyDefined, setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance
)
-import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
+import OccName ( setOccNameSpace, dataName )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
+import Maybes ( maybeToBool, catMaybes, mapMaybe )
+import UniqFM ( emptyUFM, listToUFM, plusUFM_C )
import Unique ( getUnique )
import Util ( removeDups, equivClassesByUniq, sortLt )
import List ( partition )
-> RnMG (Maybe (ExportEnv,
GlobalRdrEnv,
FixityEnv, -- Fixities for local decls only
- NameEnv AvailInfo -- Maps a name to its parent AvailInfo
+ AvailEnv -- Maps a name to its parent AvailInfo
-- Just for in-scope things only
))
-- Nothing => no need to recompile
-getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
+getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
else
- filterImports imp_mod_name import_spec avails
- `thenRn` \ (filtered_avails, hides, explicits) ->
+ filterImports imp_mod_name import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
+ qualifyImports imp_mod_name
+ (not qual_only) -- Maybe want unqualified names
+ as_mod hides
+ (improveAvails imp_mod iloc explicits
+ is_unqual filtered_avails)
+
+
+improveAvails imp_mod iloc explicits is_unqual avails
-- We 'improve' the provenance by setting
-- (a) the import-reason field, so that the Name says how it came into scope
-- including whether it's explicitly imported
-- (b) the print-unqualified field
- -- But don't fiddle with wired-in things or we get in a twist
- let
- improve_prov name =
- setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
- (is_unqual name))
- is_explicit name = name `elemNameSet` explicits
- in
- qualifyImports imp_mod_name
- (not qual_only) -- Maybe want unqualified names
- as_mod hides
- filtered_avails improve_prov
- `thenRn` \ (rdr_name_env, mod_avails) ->
+ = map improve_avail avails
+ where
+ improve_avail (Avail n) = Avail (improve n)
+ improve_avail (AvailTC n ns) = AvailTC n (map improve ns) -- n doesn't matter
- returnRn (rdr_name_env, mod_avails)
+ improve name = setNameProvenance name
+ (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
+ (is_unqual name))
+ is_explicit name = name `elemNameSet` explicits
\end{code}
Nothing -- no 'as M'
[] -- Hide nothing
avails
- (\n -> n)
where
mod = mkThisModule mod_name
getFixities acc (FixD fix)
= fix_decl acc fix
- getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _))
+ getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _))
= foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-- Get fixities from class decl sigs too.
getFixities acc other_decl
-> RnMG ([AvailInfo], -- What's actually imported
[AvailInfo], -- What's to be hidden
-- (the unqualified version, that is)
+ -- (We need to return both the above sets, because
+ -- the qualified version is never hidden; so we can't
+ -- implement hiding by reducing what's imported.)
NameSet) -- What was imported explicitly
-- Complains if import spec mentions things that the module doesn't export
= returnRn (imports, [], emptyNameSet)
filterImports mod (Just (want_hiding, import_items)) avails
- = mapMaybeRn check_item import_items `thenRn` \ avails_w_explicits ->
+ = flatMapRn get_item import_items `thenRn` \ avails_w_explicits ->
let
(item_avails, explicits_s) = unzip avails_w_explicits
explicits = foldl addListToNameSet emptyNameSet explicits_s
-- they won't make any difference because naked entities like T
-- in an import list map to TcOccs, not VarOccs.
- check_item item@(IEModuleContents _)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
+ bale_out item = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn []
+
+ get_item item@(IEModuleContents _) = bale_out item
+
+ get_item item@(IEThingAll _)
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ addWarnRn (dodgyImportWarn mod item) `thenRn_`
+ returnRn [(avail, [availName avail])]
+ Just avail -> returnRn [(avail, [availName avail])]
+
+ get_item item@(IEThingAbs n)
+ | want_hiding -- hiding( C )
+ -- Here the 'C' can be a data constructor *or* a type/class
+ = case catMaybes [check_item item, check_item (IEThingAbs data_n)] of
+ [] -> bale_out item
+ avails -> returnRn [(a, []) | a <- avails]
+ -- The 'explicits' list is irrelevant when hiding
+ where
+ data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName)
+
+ get_item item
+ = case check_item item of
+ Nothing -> bale_out item
+ Just avail -> returnRn [(avail, availNames avail)]
check_item item
| not (maybeToBool maybe_in_import_avails) ||
not (maybeToBool maybe_filtered_avail)
- = addErrRn (badImportItemErr mod item) `thenRn_`
- returnRn Nothing
-
- | dodgy_import = addWarnRn (dodgyImportWarn mod item) `thenRn_`
- returnRn (Just (filtered_avail, explicits))
+ = Nothing
- | otherwise = returnRn (Just (filtered_avail, explicits))
+ | otherwise
+ = Just filtered_avail
where
wanted_occ = rdrNameOcc (ieName item)
Just avail = maybe_in_import_avails
maybe_filtered_avail = filterAvail item avail
Just filtered_avail = maybe_filtered_avail
- explicits | dot_dot = [availName filtered_avail]
- | otherwise = availNames filtered_avail
-
- dot_dot = case item of
- IEThingAll _ -> True
- other -> False
-
- dodgy_import = case (item, avail) of
- (IEThingAll _, AvailTC _ [n]) -> True
- -- This occurs when you import T(..), but
- -- only export T abstractly. The single [n]
- -- in the AvailTC is the type or class itself
-
- other -> False
\end{code}
-> Maybe ModuleName -- Optional "as M" part
-> [AvailInfo] -- What's to be hidden
-> Avails -- Whats imported and how
- -> (Name -> Name) -- Improves the provenance on imported things
-> RnMG (GlobalRdrEnv, ExportAvails)
- -- NB: the Names in ExportAvails don't have the improve-provenance
- -- function applied to them
- -- We could fix that, but I don't think it matters
-qualifyImports this_mod unqual_imp as_mod hides
- avails improve_prov
+qualifyImports this_mod unqual_imp as_mod hides avails
=
-- Make the name environment. We're talking about a
-- single module here, so there must be no name clashes.
| unqual_imp = env2
| otherwise = env1
where
- env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) better_name
- env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) better_name
- occ = nameOccName name
- better_name = improve_prov name
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual qual_mod occ) name
+ env2 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) name
+ occ = nameOccName name
del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
where
rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
+
+
+mkEmptyExportAvails :: ModuleName -> ExportAvails
+mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
+
+mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
+mkExportAvails mod_name unqual_imp name_env avails
+ = (mod_avail_env, entity_avail_env)
+ where
+ mod_avail_env = unitFM mod_name unqual_avails
+
+ -- unqual_avails is the Avails that are visible in *unqualfied* form
+ -- (1.4 Report, Section 5.1.1)
+ -- For example, in
+ -- import T hiding( f )
+ -- we delete f from avails
+
+ unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports
+ | otherwise = mapMaybe prune avails
+
+ prune (Avail n) | unqual_in_scope n = Just (Avail n)
+ prune (Avail n) | otherwise = Nothing
+ prune (AvailTC n ns) | null uqs = Nothing
+ | otherwise = Just (AvailTC n uqs)
+ where
+ uqs = filter unqual_in_scope ns
+
+ unqual_in_scope n = unQualInScope name_env n
+
+ entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ name <- availNames avail]
+
+plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
+plusExportAvails (m1, e1) (m2, e2)
+ = (plusFM_C (++) m1 m2, plusAvailEnv e1 e2)
+ -- ToDo: wasteful: we do this once for each constructor!
\end{code}
-- the main worker function in exportsFromAvail
= ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
- NameEnv AvailInfo) -- The accumulated exported stuff, kept in an env
+ AvailEnv) -- The accumulated exported stuff, kept in an env
-- so we can common-up related AvailInfos
type ExportOccMap = FiniteMap OccName (Name, RdrNameIE)
(mod_avail_env, entity_avail_env)
global_name_env
= foldlRn exports_from_item
- ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
+ ([], emptyFM, emptyAvailEnv) export_items `thenRn` \ (_, _, export_avail_map) ->
let
export_avails :: [AvailInfo]
export_avails = nameEnvElts export_avail_map
Just mod_avails -> foldlRn (check_occs ie) occs mod_avails
`thenRn` \ occs' ->
let
- avails' = foldl add_avail avails mod_avails
+ avails' = foldl addAvail avails mod_avails
in
returnRn (mod:mods, occs', avails')
= failWithRn acc (exportItemErr ie)
| otherwise -- Phew! It's OK! Now to check the occurrence stuff!
- = check_occs ie occs export_avail `thenRn` \ occs' ->
- returnRn (mods, occs', add_avail avails export_avail)
+
+
+ = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_`
+ check_occs ie occs export_avail `thenRn` \ occs' ->
+ returnRn (mods, occs', addAvail avails export_avail)
where
rdr_name = ieName ie
enough_avail = maybeToBool maybe_export_avail
Just export_avail = maybe_export_avail
-add_avail avails avail = addToNameEnv_C plusAvail avails (availName avail) avail
+ ok_item (IEThingAll _) (AvailTC _ [n]) = False
+ -- This occurs when you import T(..), but
+ -- only export T abstractly. The single [n]
+ -- in the AvailTC is the type or class itself
+ ok_item _ _ = True
check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap
check_occs ie occs avail
= sep [ptext SLIT("Module"), quotes (pprModuleName mod),
ptext SLIT("does not export"), quotes (ppr ie)]
-dodgyImportWarn mod (IEThingAll tc)
- = sep [ptext SLIT("Module") <+> quotes (pprModuleName mod)
- <+> ptext SLIT("exports") <+> quotes (ppr tc),
- ptext SLIT("with no constructors/class operations;"),
- ptext SLIT("yet it is imported with a (..)")]
+dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item
+dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item
+dodgyMsg kind item@(IEThingAll tc)
+ = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item),
+ ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"),
+ ptext SLIT("but it has none; it is a type synonym or abstract type or class") ]
+
modExportErr mod
= hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModuleName mod)]
exportItemErr export_item
- = sep [ ptext SLIT("Bad export item"), quotes (ppr export_item)]
+ = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item),
+ ptext SLIT("attempts to export constructors or class methods that are not visible here") ]
exportClashErr occ_name ie1 ie2
= hsep [ptext SLIT("The export items"), quotes (ppr ie1)
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
ptext SLIT("and") <+> ppr loc2]
-
\end{code}