#include "HsVersions.h"
-import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedNames )
+import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches,
+ opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrName(..), RdrNameIE,
- rdrNameOcc, ieOcc, isQual, qual
+ rdrNameOcc, isQual, qual, isClassDataConRdrName
)
import HsTypes ( getTyVarName, replaceTyVarName )
-import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule )
+import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
+import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
- occNameString, occNameFlavour, getSrcLoc,
+ occNameFlavour, getSrcLoc,
NameSet, emptyNameSet, addListToNameSet, nameSetToList,
mkLocalName, mkGlobalName, modAndOcc,
nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
- pprProvenance, pprOccName, pprModule, pprNameProvenance,
- isLocalName
+ pprOccName, isLocalName
)
import TyCon ( TyCon )
-import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import FiniteMap
import Unique ( Unique, Uniquable(..), unboundKey )
import UniqFM ( listToUFM, plusUFM_C )
-import Maybes ( maybeToBool )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
lookupRn :: RdrName
-> Maybe Name -- Result of environment lookup
-> RnMS s Name
-
-lookupRn rdr_name (Just name)
+lookupRn rdr_name (Just name)
= -- Found the name in the envt
returnRn name -- In interface mode the only things in
-- the environment are things in local (nested) scopes
+lookupRn rdr_name nm@Nothing
+ = tryLookupRn rdr_name nm `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left (nm,err) -> failWithRn nm err
+ Right nm -> returnRn nm
+
+tryLookupRn :: RdrName
+ -> Maybe Name -- Result of environment lookup
+ -> RnMS s (Either (Name, ErrMsg) Name)
+tryLookupRn rdr_name (Just name)
+ = -- Found the name in the envt
+ returnRn (Right name) -- In interface mode the only things in
+ -- the environment are things in local (nested) scopes
-lookupRn rdr_name Nothing
+-- lookup in environment, but don't flag an error if
+-- name is not found.
+tryLookupRn rdr_name Nothing
= -- We didn't find the name in the environment
getModeRn `thenRn` \ mode ->
case mode of {
- SourceMode -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name) ;
- -- Souurce mode; lookup failure is an error
+ SourceMode -> returnRn (Left ( mkUnboundName rdr_name
+ , unknownNameErr rdr_name));
+ -- Source mode; lookup failure is an error
InterfaceMode _ _ ->
-- So, qualify the unqualified name with the
-- module of the interface file, and try again
case rdr_name of
- Unqual occ -> getModuleRn `thenRn` \ mod ->
- newImportedGlobalName mod occ HiFile
- Qual mod occ hif -> newImportedGlobalName mod occ hif
+ Unqual occ ->
+ getModuleRn `thenRn` \ mod ->
+ newImportedGlobalName mod occ HiFile `thenRn` \ nm ->
+ returnRn (Right nm)
+ Qual mod occ hif ->
+ newImportedGlobalName mod occ hif `thenRn` \ nm ->
+ returnRn (Right nm)
}
-- deciding which instance declarations to import.
lookupOccRn :: RdrName -> RnMS s Name
lookupOccRn rdr_name
+ = tryLookupOccRn rdr_name `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left (nm, err) -> failWithRn nm err
+ Right nm -> returnRn nm
+
+-- tryLookupOccRn is the fail-safe version of lookupOccRn, returning
+-- back the error rather than immediately flagging it. It is only
+-- directly used by RnExpr.rnExpr to catch and rewrite unbound
+-- uses of `assert'.
+tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name)
+tryLookupOccRn rdr_name
= lookupNameRn rdr_name `thenRn` \ maybe_name ->
- lookupRn rdr_name maybe_name `thenRn` \ name ->
- let
+ tryLookupRn rdr_name maybe_name `thenRn` \ name_or_error ->
+ case name_or_error of
+ Left _ -> returnRn name_or_error
+ Right name ->
+ let
name' = mungePrintUnqual rdr_name name
- in
- addOccurrenceName name'
+ in
+ addOccurrenceName name' `thenRn_`
+ returnRn name_or_error
+
-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
-- environment only. It's used for record field names only.
\begin{code}
plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv
plusGlobalNameEnvRn env1 env2
- = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_`
+ = mapRn addNameClashErrRn (conflictsFM conflicting_name env1 env2) `thenRn_`
returnRn (env1 `plusFM` env2)
addOneToGlobalNameEnv :: GlobalNameEnv -> RdrName -> (Name, HowInScope) -> RnM s d GlobalNameEnv
addOneToGlobalNameEnv env rdr_name name
= case lookupFM env rdr_name of
Just name2 | conflicting_name name name2
- -> addErrRn (nameClashErr (rdr_name, (name, name2))) `thenRn_`
+ -> addNameClashErrRn (rdr_name, (name, name2)) `thenRn_`
returnRn env
other -> returnRn (addToFM env rdr_name name)
-=============== Avails ================
+=============== ExportAvails ================
\begin{code}
-mkExportAvails :: Bool -> Module -> [AvailInfo] -> ExportAvails
-mkExportAvails unqualified_import mod_name avails
+mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails
+mkExportAvails mod_name unqual_imp name_env avails
= (mod_avail_env, entity_avail_env)
where
- -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1)
- mod_avail_env | unqualified_import = unitFM mod_name avails
- | otherwise = emptyFM
-
+ 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 = [prune avail | avail <- avails]
+
+ prune (Avail n) | unqual_in_scope n = Avail n
+ prune (Avail n) | otherwise = NotAvailable
+ prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns)
+
+ unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env
+
entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
name <- availEntityNames avail]
avail_occs = map nameOccName ns
wanted_occs = map rdrNameOcc (want:wants)
-filterAvail (IEThingAbs _) (AvailTC n ns)
- | n `elem` ns = AvailTC n [n]
+filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns )
+ AvailTC n [n]
filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms
\begin{code}
+warnUnusedBinds, warnUnusedMatches, warnUnusedImports :: NameSet -> RnM s d ()
+
+warnUnusedBinds names
+ | opt_WarnUnusedBinds = warnUnusedNames names
+ | otherwise = returnRn ()
+
+warnUnusedMatches names
+ | opt_WarnUnusedMatches = warnUnusedNames names
+ | otherwise = returnRn ()
+
+warnUnusedImports names
+ | opt_WarnUnusedImports = warnUnusedNames names
+ | otherwise = returnRn ()
+
warnUnusedNames :: NameSet -> RnM s d ()
warnUnusedNames names
- | not opt_WarnUnusedNames = returnRn ()
- | otherwise = mapRn warn (nameSetToList names) `thenRn_`
- returnRn ()
+ = mapRn warn (nameSetToList names) `thenRn_`
+ returnRn ()
where
warn name = pushSrcLocRn (getSrcLoc name) $
addWarnRn (unusedNameWarn name)
unusedNameWarn name = quotes (ppr name) <+> ptext SLIT("is bound but not used")
-nameClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
- = hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
- 4 (vcat [ppr how_in_scope1,
- ppr how_in_scope2])
+addNameClashErrRn (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
+ | isClassDataConRdrName rdr_name
+ -- Nasty hack to prevent error messages complain about conflicts for ":C",
+ -- where "C" is a class. There'll be a message about C, and :C isn't
+ -- the programmer's business. There may be a better way to filter this
+ -- out, but I couldn't get up the energy to find it.
+ = returnRn ()
+
+ | otherwise
+ = addErrRn (hang (hsep [ptext SLIT("Conflicting definitions for"), quotes (ppr rdr_name)])
+ 4 (vcat [ppr how_in_scope1,
+ ppr how_in_scope2]))
fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
= hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
projects / ghc-hetmet.git / blobdiff