X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=dff9abed0da1693f64f615127d5537f416dd62ee;hb=d3e697b8d842bd43329d470f2bc424a6dcb88d89;hp=551c6c48f5a89c7854b33ac05a445c1959ec26e5;hpb=6cea635ae32abdb01aec6aae05477924b40c3148;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 551c6c4..dff9abe 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,28 +8,28 @@ module RnEnv where -- Export everything #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 @@ -255,19 +255,33 @@ Looking up a name in the RnEnv. 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 _ _ -> @@ -280,9 +294,13 @@ lookupRn rdr_name Nothing -- 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) } @@ -322,12 +340,28 @@ lookupBndrRn rdr_name -- 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. @@ -432,14 +466,14 @@ plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) \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) @@ -644,21 +678,42 @@ conflictFM bad fm key elt \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)])