\section[RnNames]{Extracting imported and top-level names in scope}
\begin{code}
-#include "HsVersions.h"
-
module RnNames (
getGlobalNames
) where
-IMP_Ubiq()
+#include "HsVersions.h"
+
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
+ opt_SourceUnchanged
+ )
-import CmdLineOpts ( opt_SourceUnchanged )
-import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar,
- TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig
+import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..),
+ IE(..), ieName,
+ FixityDecl(..),
+ collectTopBinders
)
-import HsBinds ( collectTopBinders )
-import HsImpExp ( ieName )
-import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl),
- SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl),
- rdrNameOcc
+import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), RdrNameImportDecl,
+ RdrNameHsModule, RdrNameFixityDecl,
+ rdrNameOcc, ieOcc
)
import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
-import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate )
+import RnIfaces ( getInterfaceExports, getDeclBinders, recordSlurp, checkUpToDate )
+import BasicTypes ( IfaceFlavour(..) )
import RnEnv
import RnMonad
+
import FiniteMap
import PrelMods
import UniqFM ( UniqFM, emptyUFM, addListToUFM_C, lookupUFM )
import Bag ( Bag, bagToList )
import Maybes ( maybeToBool, expectJust )
import Name
-import Pretty
-import PprStyle ( PprStyle(..) )
-import Util ( panic, pprTrace )
+import Outputable
+import Util ( removeDups )
\end{code}
\begin{code}
getGlobalNames :: RdrNameHsModule
- -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo]))
- -- Nothing <=> no need to recompile
+ -> RnMG (Maybe (ExportEnv, RnEnv, NameSet, Name -> PrintUnqualified))
+ -- The NameSet is the set of names that are
+ -- either locally defined,
+ -- or explicitly imported
+ -- Nothing => no need to recompile
getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
= fixRn (\ ~(rec_exp_fn, _) ->
-- PROCESS LOCAL DECLS
-- Do these *first* so that the correct provenance gets
-- into the global name cache.
- importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails) ->
+ importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails, local_avails) ->
-- PROCESS IMPORT DECLS
- mapAndUnzipRn importsFromImportDecl all_imports
- `thenRn` \ (imp_rn_envs, imp_avails_s) ->
-
- -- CHECK FOR EARLY EXIT
- checkEarlyExit this_mod `thenRn` \ early_exit ->
- if early_exit then
- returnRn (junk_exp_fn, Nothing)
- else
+ mapAndUnzip3Rn importsFromImportDecl all_imports
+ `thenRn` \ (imp_rn_envs, imp_avails_s, explicit_imports_s) ->
-- COMBINE RESULTS
- -- We put the local env first, so that a local provenance
+ -- We put the local env second, so that a local provenance
-- "wins", even if a module imports itself.
foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env ->
- plusRnEnv local_rn_env imp_rn_env `thenRn` \ rn_env ->
+ plusRnEnv imp_rn_env local_rn_env `thenRn` \ rn_env ->
+
+ -- TRY FOR EARLY EXIT
+ -- We can't go for an early exit before this because we have to check
+ -- for name clashes. Consider:
+ --
+ -- module A where module B where
+ -- import B h = True
+ -- f = h
+ --
+ -- Suppose I've compiled everything up, and then I add a
+ -- new definition to module B, that defines "f".
+ --
+ -- Then I must detect the name clash in A before going for an early
+ -- exit. The early-exit code checks what's actually needed from B
+ -- to compile A, and of course that doesn't include B.f. That's
+ -- why we wait till after the plusRnEnv stuff to do the early-exit.
+ checkEarlyExit this_mod `thenRn` \ up_to_date ->
+ if up_to_date then
+ returnRn (error "early exit", Nothing)
+ else
+
+
+ -- PROCESS EXPORT LISTS
let
- all_avails :: ModuleAvails
- all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
- local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod)
+ export_avails :: ExportAvails
+ export_avails = foldr plusExportAvails local_mod_avails imp_avails_s
+
+ explicit_names :: NameSet -- locally defined or explicitly imported
+ explicit_names = foldr add_on emptyNameSet (local_avails : explicit_imports_s)
+ add_on avails names = foldr (unionNameSets . mkNameSet . availNames) names avails
in
-
- -- PROCESS EXPORT LISTS
- exportsFromAvail this_mod exports all_avails rn_env
+ exportsFromAvail this_mod exports export_avails rn_env
`thenRn` \ (export_fn, export_env) ->
- returnRn (export_fn, Just (export_env, rn_env, local_avails))
+ -- RECORD THAT LOCALLY DEFINED THINGS ARE AVAILABLE
+ mapRn (recordSlurp Nothing Compulsory) local_avails `thenRn_`
+
+ -- BUILD THE "IMPORT FN". It just tells whether a name is in
+ -- scope in an unqualified form.
+ let
+ print_unqual = mkImportFn imp_rn_env
+ in
+
+ returnRn (export_fn, Just (export_env, rn_env, explicit_names, print_unqual))
) `thenRn` \ (_, result) ->
returnRn result
where
all_imports = prel_imports ++ imports
+ -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
+ -- because the former doesn't even look at Prelude.hi for instance declarations,
+ -- whereas the latter does.
prel_imports | this_mod == pRELUDE ||
- explicit_prelude_import = []
+ explicit_prelude_import ||
+ opt_NoImplicitPrelude
+ = []
| otherwise = [ImportDecl pRELUDE
False {- Not qualified -}
+ HiFile {- Not source imported -}
Nothing {- No "as" -}
Nothing {- No import list -}
mod_loc]
explicit_prelude_import
- = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ])
+ = not (null [ () | (ImportDecl mod qual _ _ _ _) <- imports, mod == pRELUDE ])
\end{code}
\begin{code}
checkEarlyExit mod
- = if not opt_SourceUnchanged then
- -- Source code changed; look no further
+ = checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ returnRn True
+ else
+
+ traceRn (text "Considering whether compilation is required...") `thenRn_`
+ if not opt_SourceUnchanged then
+ -- Source code changed and no errors yet... carry on
+ traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_`
returnRn False
else
- -- Unchanged source; look further
- -- We check for
- -- (a) errors so far. These can arise if a module imports
- -- something that's no longer exported by the imported module
- -- (b) usage information up to date
- checkErrsRn `thenRn` \ no_errs_so_far ->
- checkUpToDate mod `thenRn` \ up_to_date ->
- returnRn (no_errs_so_far && up_to_date)
+
+ -- Unchanged source, and no errors yet; see if usage info
+ -- up to date, and exit if so
+ checkUpToDate mod `thenRn` \ up_to_date ->
+ putDocRn (text "Compilation" <+>
+ text (if up_to_date then "IS NOT" else "IS") <+>
+ text "required") `thenRn_`
+ returnRn up_to_date
\end{code}
-
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
- -> RnMG (RnEnv, ModuleAvails)
-
- -- Check for "import M ()", and then don't even look at M.
- -- This makes sense, and is actually rather useful for the Prelude.
-importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc)
- = returnRn (emptyRnEnv, emptyModuleAvails)
+ -> RnMG (RnEnv, ExportAvails, [AvailInfo])
-importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc)
+importsFromImportDecl (ImportDecl mod qual_only as_source as_mod import_spec loc)
= pushSrcLocRn loc $
- getInterfaceExports mod `thenRn` \ (avails, fixities) ->
- filterImports mod import_spec avails `thenRn` \ filtered_avails ->
+ getInterfaceExports mod as_source `thenRn` \ (avails, fixities) ->
+ filterImports mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) ->
let
- filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns)
- | Avail n ns <- filtered_avails
- ]
- fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ]
+ how_in_scope = FromImportDecl mod loc
in
- qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities')
- where
- set_name_prov name = setNameProvenance name provenance
- provenance = Imported mod loc
+ qualifyImports mod
+ True -- Want qualified names
+ (not qual_only) -- Maybe want unqualified names
+ as_mod
+ hides
+ filtered_avails (\n -> how_in_scope)
+ [ (occ,(fixity,how_in_scope)) | (occ,fixity) <- fixities ]
+ `thenRn` \ (rn_env, mod_avails) ->
+ returnRn (rn_env, mod_avails, explicits)
\end{code}
= foldlRn getLocalDeclBinders [] decls `thenRn` \ avails ->
mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities ->
qualifyImports mod
- False -- Not qualified
+ False -- Don't want qualified names
+ True -- Want unqualified names
Nothing -- No "as M" part
- (ExportEnv avails fixities)
+ [] -- Hide nothing
+ avails (\n -> FromLocalDefn (getSrcLoc n))
+ fixities
+ `thenRn` \ (rn_env, mod_avails) ->
+ returnRn (rn_env, mod_avails, avails)
where
newLocalName rdr_name loc
= newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
getLocalDeclBinders avails decl
= getDeclBinders newLocalName decl `thenRn` \ avail ->
- returnRn (avail : avails)
+ case avail of
+ NotAvailable -> returnRn avails -- Instance decls and suchlike
+ other -> returnRn (avail : avails)
do_one (rdr_name, loc)
= newLocalName rdr_name loc `thenRn` \ name ->
- returnRn (Avail name [])
+ returnRn (Avail name)
\end{code}
%************************************************************************
filterImports :: Module
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin
-> [AvailInfo] -- What's available
- -> RnMG [AvailInfo] -- What's actually imported
- -- Complains if import spec mentions things the
- -- module doesn't export
+ -> RnMG ([AvailInfo], -- What's actually imported
+ [AvailInfo], -- What's to be hidden (the unqualified version, that is)
+ [AvailInfo]) -- What was imported explicitly
+ -- Complains if import spec mentions things that the module doesn't export
+ -- Warns/informs if import spec contains duplicates.
filterImports mod Nothing imports
- = returnRn imports
+ = returnRn (imports, [], [])
filterImports mod (Just (want_hiding, import_items)) avails
- = -- Check that each import item mentions things that are actually available
- mapRn check_import_item import_items `thenRn_`
-
- -- Return filtered environment; no need to filter fixities
- returnRn (map new_avail avails)
+ = mapRn check_item import_items `thenRn` \ item_avails ->
+ if want_hiding
+ then
+ returnRn (avails, item_avails, []) -- All imported; item_avails to be hidden
+ else
+ returnRn (item_avails, [], item_avails) -- Just item_avails imported; nothing to be hidden
where
- import_fm :: FiniteMap OccName RdrNameIE
- import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items]
-
- avail_fm :: FiniteMap OccName AvailInfo
- avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails]
-
- new_avail NotAvailable = NotAvailable
- new_avail avail@(Avail name _)
- | not in_import_items && want_hiding = avail
- | not in_import_items && not want_hiding = NotAvailable
- | in_import_items && want_hiding = NotAvailable
- | in_import_items && not want_hiding = filtered_avail
- where
- maybe_import_item = lookupFM import_fm (nameOccName name)
- in_import_items = maybeToBool maybe_import_item
- Just import_item = maybe_import_item
- filtered_avail = filterAvail import_item avail
-
- check_import_item :: RdrNameIE -> RnMG ()
- check_import_item item
- = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail)
- (badImportItemErr mod item)
- where
- item_name = ieOcc item
- maybe_matching_avail = lookupFM avail_fm item_name
- Just avail = maybe_matching_avail
-
- sub_names_ok (IEVar _) _ = True
- sub_names_ok (IEThingAbs _) _ = True
- sub_names_ok (IEThingAll _) _ = True
- sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted
- where
- has_list = map nameOccName has
- sub_names_ok other1 other2 = False
+ import_fm :: FiniteMap OccName AvailInfo
+ import_fm = listToFM [ (nameOccName name, avail)
+ | avail <- avails,
+ name <- availEntityNames avail]
+
+ check_item item@(IEModuleContents _)
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn NotAvailable
+
+ check_item item
+ | not (maybeToBool maybe_in_import_avails) ||
+ (case filtered_avail of { NotAvailable -> True; other -> False })
+ = addErrRn (badImportItemErr mod item) `thenRn_`
+ returnRn NotAvailable
+
+ | otherwise = returnRn filtered_avail
+
+ where
+ maybe_in_import_avails = lookupFM import_fm (ieOcc item)
+ Just avail = maybe_in_import_avails
+ filtered_avail = filterAvail item avail
\end{code}
@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
of an import decl, and deals with producing an @RnEnv@ with the
-right qaulified names. It also turns the @Names@ in the @ExportEnv@ into
+right qualified names. It also turns the @Names@ in the @ExportEnv@ into
fully fledged @Names@.
\begin{code}
-qualifyImports :: Module -- Improrted module
- -> Bool -- True <=> qualified import
+qualifyImports :: Module -- Imported module
+ -> Bool -- True <=> want qualified import
+ -> Bool -- True <=> want unqualified import
-> Maybe Module -- Optional "as M" part
- -> ExportEnv -- What's imported
- -> RnMG (RnEnv, ModuleAvails)
-
-qualifyImports this_mod qual as_mod (ExportEnv avails fixities)
- = -- Make the qualified-name environments, checking of course for clashes
- foldlRn add_name emptyNameEnv avails `thenRn` \ name_env ->
- foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env ->
+ -> [AvailInfo] -- What's to be hidden
+ -> Avails -> (Name -> HowInScope) -- Whats imported and how
+ -> [(OccName, (Fixity, HowInScope))] -- Ditto for fixities
+ -> RnMG (RnEnv, ExportAvails)
+
+qualifyImports this_mod qual_imp unqual_imp as_mod hides
+ avails name_to_his fixities
+ =
+ -- Make the name environment. Even though we're talking about a
+ -- single import module there might still be name clashes,
+ -- because it might be the module being compiled.
+ foldlRn add_avail emptyGlobalNameEnv avails `thenRn` \ name_env1 ->
+ let
+ -- Delete things that are hidden
+ name_env2 = foldl del_avail name_env1 hides
- -- Deal with the "qualified" part; if not qualifies then add unqualfied bindings
- if qual then
- returnRn (RnEnv name_env fixity_env, mod_avail_env)
- else
- returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env)
+ -- Create the fixity env
+ fixity_env = foldl (add_fixity name_env2) emptyFixityEnv fixities
+ -- Create the export-availability info
+ export_avails = mkExportAvails unqual_imp qual_mod avails
+ in
+ returnRn (RnEnv name_env2 fixity_env, export_avails)
where
- mod_avail_env = unitFM this_mod avails
-
- add_name name_env NotAvailable = returnRn name_env
- add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns)
-
- add_one :: NameEnv -> Name -> RnMG NameEnv
- add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name
- where
- occ_name = nameOccName name
-
- add_fixity name_env fixity_env (occ_name, fixity, provenance)
- | maybeToBool (lookupFM name_env qual_name) -- The name is imported
- = addOneToFixityEnvRn fixity_env qual_name (fixity,provenance)
- | otherwise -- It ain't imported
- = returnRn fixity_env
- where
- qual_name = Qual this_mod occ_name
+ qual_mod = case as_mod of
+ Nothing -> this_mod
+ Just another_name -> another_name
+
+ add_avail :: GlobalNameEnv -> AvailInfo -> RnMG GlobalNameEnv
+ add_avail env avail = foldlRn add_name env (availNames avail)
+
+ add_name env name = add qual_imp env (Qual qual_mod occ err_hif) `thenRn` \ env1 ->
+ add unqual_imp env1 (Unqual occ)
+ where
+ add False env rdr_name = returnRn env
+ add True env rdr_name = addOneToGlobalNameEnv env rdr_name (name, name_to_his name)
+ occ = nameOccName name
+
+ del_avail env avail = foldl delOneFromGlobalNameEnv env rdr_names
+ where
+ rdr_names = map (Unqual . nameOccName) (availNames avail)
+
+ add_fixity name_env fix_env (occ_name, fixity)
+ = add qual $ add unqual $ fix_env
+ where
+ qual = Qual qual_mod occ_name err_hif
+ unqual = Unqual occ_name
+
+ add rdr_name fix_env | maybeToBool (lookupFM name_env rdr_name)
+ = addOneToFixityEnv fix_env rdr_name fixity
+ | otherwise
+ = fix_env
+
+err_hif = error "qualifyImports: hif" -- Not needed in key to mapping
\end{code}
unQualify adds an Unqual binding for every existing Qual binding.
\begin{code}
unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
-unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm]
+unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ _, elt) <- fmToList fm]
\end{code}
%************************************************************************
\begin{code}
-fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance)
+fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, HowInScope))
fixityFromFixDecl (FixityDecl rdr_name fixity loc)
- = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc)
+ = returnRn (rdrNameOcc rdr_name, (fixity, FromLocalDefn loc))
\end{code}
is: two exported things must have different @OccNames@.
\begin{code}
-type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo)
+type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo, Int{-no. of clashes-})
-- The FM maps each OccName to the RdrNameIE that gave rise to it,
-- for error reporting, as well as to its AvailInfo
emptyAvailEnv = emptyFM
-unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv
-unitAvailEnv ie NotAvailable
- = emptyFM
-unitAvailEnv ie avail@(Avail n ns)
- = unitFM (nameOccName n) (ie,avail)
+{-
+ Add new entry to environment. Checks for name clashes, i.e.,
+ plain duplicates or exported entity pairs that have different OccNames.
+ (c.f. 5.1.1 of Haskell 1.4 report.)
+-}
+addAvailEnv :: Bool -> RdrNameIE -> AvailEnv -> AvailInfo -> RnM s d AvailEnv
+addAvailEnv warn_dups ie env NotAvailable = returnRn env
+addAvailEnv warn_dups ie env (AvailTC _ []) = returnRn env
+addAvailEnv warn_dups ie env avail
+ | warn_dups = mapMaybeRn (addErrRn . availClashErr) () conflict `thenRn_`
+ returnRn (addToFM_C addAvail env key elt)
+ | otherwise = returnRn (addToFM_C addAvail env key elt)
+ where
+ key = nameOccName (availName avail)
+ elt = (ie,avail,reports_on)
-plusAvailEnv a1 a2
- = mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2) `thenRn_`
- returnRn (plusFM_C plus_avail a1 a2)
+ reports_on
+ | maybeToBool dup = 1
+ | otherwise = 0
-listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
-listToAvailEnv ie items
- = foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items)
+ conflict = conflictFM bad_avail env key elt
+ dup
+ | warn_dups = conflictFM dup_avail env key elt
+ | otherwise = Nothing
-bad_avail (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2 -- Same OccName, different Name
-plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2)
+addListToAvailEnv :: AvailEnv -> RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
+addListToAvailEnv env ie items = foldlRn (addAvailEnv False ie) env items
+
+bad_avail (ie1,avail1,r1) (ie2,avail2,r2)
+ = availName avail1 /= availName avail2 -- Same OccName, different Name
+dup_avail (ie1,avail1,r1) (ie2,avail2,r2)
+ = availName avail1 == availName avail2 -- Same OccName & avail.
+
+addAvail (ie1,a1,r1) (ie2,a2,r2) = (ie1, a1 `plusAvail` a2, r1 + r2)
\end{code}
+Processing the export list.
+
+You might think that we should record things that appear in the export list as
+``occurrences'' (using addOccurrenceName), but you'd be wrong. We do check (here)
+that they are in scope, but there is no need to slurp in their actual declaration
+(which is what addOccurrenceName forces). Indeed, doing so would big trouble when
+compiling PrelBase, because it re-exports GHC, which includes takeMVar#, whose type
+includes ConcBase.StateAndSynchVar#, and so on...
\begin{code}
exportsFromAvail :: Module
-> Maybe [RdrNameIE] -- Export spec
- -> ModuleAvails
+ -> ExportAvails
-> RnEnv
-> RnMG (Name -> ExportFlag, ExportEnv)
-- Complains if two distinct exports have same OccName
+ -- Warns about identical exports.
-- Complains about exports items not in scope
-exportsFromAvail this_mod Nothing all_avails rn_env
- = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env
-
-exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env)
- = mapRn exports_from_item export_items `thenRn` \ avail_envs ->
- foldlRn plusAvailEnv emptyAvailEnv avail_envs `thenRn` \ export_avail_env ->
+exportsFromAvail this_mod Nothing export_avails rn_env
+ = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env
+
+exportsFromAvail this_mod (Just export_items)
+ (mod_avail_env, entity_avail_env)
+ (RnEnv global_name_env fixity_env)
+ = checkForModuleExportDups export_items `thenRn` \ export_items' ->
+ foldlRn exports_from_item emptyAvailEnv export_items' `thenRn` \ export_avail_env ->
+ let
+ dup_entries = fmToList (filterFM (\ _ (_,_,clashes) -> clashes > 0) export_avail_env)
+ in
+ mapRn (addWarnRn . dupExportWarn) dup_entries `thenRn_`
let
- export_avails = map snd (eltsFM export_avail_env)
+ export_avails = map (\ (_,a,_) -> a) (eltsFM export_avail_env)
export_fixities = mk_exported_fixities (availsToNameSet export_avails)
export_fn = mk_export_fn export_avails
in
returnRn (export_fn, ExportEnv export_avails export_fixities)
where
- full_avail_env :: UniqFM AvailInfo
- full_avail_env = addListToUFM_C plusAvail emptyUFM
- [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)]
- -- NB: full_avail_env won't contain bindings for data constructors and class ops,
- -- which is right and proper; attempts to export them on their own will provoke an error
-
- exports_from_item :: RdrNameIE -> RnMG AvailEnv
- exports_from_item ie@(IEModuleContents mod)
- = case lookupFM all_avails mod of
- Nothing -> failWithRn emptyAvailEnv (modExportErr mod)
- Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails] `thenRn_`
- listToAvailEnv ie avails
-
- exports_from_item ie
+ exports_from_item :: AvailEnv -> RdrNameIE -> RnMG AvailEnv
+ exports_from_item export_avail_env ie@(IEModuleContents mod)
+ = case lookupFM mod_avail_env mod of
+ Nothing -> failWithRn export_avail_env (modExportErr mod)
+ Just avails -> addListToAvailEnv export_avail_env ie avails
+
+ exports_from_item export_avail_env ie
| not (maybeToBool maybe_in_scope)
- = failWithRn emptyAvailEnv (unknownNameErr (ieName ie))
+ = failWithRn export_avail_env (unknownNameErr (ieName ie))
#ifdef DEBUG
-- I can't see why this should ever happen; if the thing is in scope
-- at all it ought to have some availability
| not (maybeToBool maybe_avail)
- = pprTrace "exportsFromAvail: curious Nothing:" (ppr PprDebug name)
- returnRn emptyAvailEnv
+ = pprTrace "exportsFromAvail: curious Nothing:" (ppr name)
+ returnRn export_avail_env
#endif
| not enough_avail
- = failWithRn emptyAvailEnv (exportItemErr ie export_avail)
+ = failWithRn export_avail_env (exportItemErr ie export_avail)
| otherwise -- Phew! It's OK!
- = addOccurrenceName Compulsory name `thenRn_`
- returnRn (unitAvailEnv ie export_avail)
+ = addAvailEnv opt_WarnDuplicateExports ie export_avail_env export_avail
where
- maybe_in_scope = lookupNameEnv name_env (ieName ie)
- Just name = maybe_in_scope
- maybe_avail = lookupUFM full_avail_env name
+ maybe_in_scope = lookupFM global_name_env (ieName ie)
+ Just (name,_) = maybe_in_scope
+ maybe_avail = lookupUFM entity_avail_env name
Just avail = maybe_avail
export_avail = filterAvail ie avail
enough_avail = case export_avail of {NotAvailable -> False; other -> True}
-- We export a fixity iff we export a thing with the same (qualified) RdrName
- mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)]
+ mk_exported_fixities :: NameSet -> [(OccName, Fixity)]
mk_exported_fixities exports
- = [ (rdrNameOcc rdr_name, fixity, prov)
- | (rdr_name, (fixity, prov)) <- fmToList fixity_env,
- export_fixity name_env exports rdr_name
- ]
+ = fmToList (foldr (perhaps_add_fixity exports)
+ emptyFM
+ (fmToList fixity_env))
+
+ perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, HowInScope))
+ -> FiniteMap OccName Fixity
+ -> FiniteMap OccName Fixity
+ perhaps_add_fixity exports (rdr_name, (fixity, how_in_scope)) fix_env
+ = let
+ do_nothing = fix_env -- The default is to pass on the env unchanged
+ in
+ -- Step 1: check whether the rdr_name is in scope; if so find its Name
+ case lookupFM global_name_env rdr_name of {
+ Nothing -> do_nothing;
+ Just (fixity_name,_) ->
+
+ -- Step 2: check whether the fixity thing is exported
+ if not (fixity_name `elemNameSet` exports) then
+ do_nothing
+ else
+
+ -- Step 3: check whether we already have a fixity for the
+ -- Name's OccName in the fix_env we are building up. This can easily
+ -- happen. the original fixity_env might contain bindings for
+ -- M.a and N.a, if a was imported via M and N.
+ -- If this does happen, we expect the fixity to be the same either way.
+ let
+ occ_name = rdrNameOcc rdr_name
+ in
+ case lookupFM fix_env occ_name of {
+ Just fixity1 -> -- Got it already
+ ASSERT( fixity == fixity1 )
+ do_nothing;
+ Nothing ->
+
+ -- Step 3: add it to the outgoing fix_env
+ addToFM fix_env occ_name fixity
+ }}
+
+{- warn and weed out duplicate module entries from export list. -}
+checkForModuleExportDups :: [RdrNameIE] -> RnMG [RdrNameIE]
+checkForModuleExportDups ls
+ | opt_WarnDuplicateExports = check_modules ls
+ | otherwise = returnRn ls
+ where
+ -- NOTE: reorders the export list by moving all module-contents
+ -- exports to the end (removing duplicates in the process.)
+ check_modules ls =
+ (case dups of
+ [] -> returnRn ()
+ ls -> mapRn (\ ds@(IEModuleContents x:_) ->
+ addWarnRn (dupModuleExport x (length ds))) ls `thenRn_`
+ returnRn ()) `thenRn_`
+ returnRn (ls_no_modules ++ no_module_dups)
+ where
+ (ls_no_modules,modules) = foldr split_mods ([],[]) ls
+
+ split_mods i@(IEModuleContents _) ~(no_ms,ms) = (no_ms,i:ms)
+ split_mods i ~(no_ms,ms) = (i:no_ms,ms)
+
+ (no_module_dups, dups) = removeDups cmp_mods modules
+ cmp_mods (IEModuleContents m1) (IEModuleContents m2) = m1 `compare` m2
+
mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag)
mk_export_fn avails
= \name -> if name `elemNameSet` exported_names
where
exported_names :: NameSet
exported_names = availsToNameSet avails
-
-export_fixity :: NameEnv -> NameSet -> RdrName -> Bool
-export_fixity name_env exports (Unqual _)
- = False -- The qualified fixity is always there as well
-export_fixity name_env exports rdr_name@(Qual _ occ)
- = case lookupFM name_env rdr_name of
- Just fixity_name -> fixity_name `elemNameSet` exports
- -- Check whether the exported thing is
- -- the one to which the fixity attaches
- other -> False -- Not even in scope
-\end{code}
-
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-ieOcc ie = rdrNameOcc (ieName ie)
-
-badImportItemErr mod ie sty
- = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie]
-
-modExportErr mod sty
- = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod]
-
-exportItemErr export_item NotAvailable sty
- = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ]
-
-exportItemErr export_item avail sty
- = ppHang (ppStr "Export item not fully in scope:")
- 4 (ppAboves [ppCat [ppStr "Wanted: ", ppr sty export_item],
- ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]])
-
-availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty
- = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name])
- 4 (ppAboves [ppr sty ie1, ppr sty ie2])
+badImportItemErr mod ie
+ = sep [ptext SLIT("Module"), quotes (pprModule mod),
+ ptext SLIT("does not export"), quotes (ppr ie)]
+
+modExportErr mod
+ = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (pprModule mod)]
+
+exportItemErr export_item NotAvailable
+ = sep [ ptext SLIT("Export item not in scope:"), quotes (ppr export_item)]
+
+exportItemErr export_item avail
+ = hang (ptext SLIT("Export item not fully in scope:"))
+ 4 (vcat [hsep [ptext SLIT("Wanted: "), ppr export_item],
+ hsep [ptext SLIT("Available:"), ppr (ieOcc export_item), pprAvail avail]])
+
+availClashErr (occ_name, ((ie1,avail1,_), (ie2,avail2,_)))
+ = hsep [ptext SLIT("The export items"), quotes (ppr ie1), ptext SLIT("and"), quotes (ppr ie2),
+ ptext SLIT("create conflicting exports for"), quotes (ppr occ_name)]
+
+dupExportWarn (occ_name, (_,_,times))
+ = hsep [quotes (ppr occ_name),
+ ptext SLIT("mentioned"), speakNTimes (times+1),
+ ptext SLIT("in export list")]
+
+dupModuleExport mod times
+ = hsep [ptext SLIT("Module"), quotes (pprModule mod),
+ ptext SLIT("mentioned"), speakNTimes times,
+ ptext SLIT("in export list")]
\end{code}