X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=270f509087d49fd515363a19148fbfa911e75159;hb=f0192b817c0ed2e0558df2b5d129f9dd0a710f81;hp=a75353b9918bab357f13e27e170047e20f2ba6fe;hpb=b1f1b152d4868976cdd12f06c8c6d99d94670dbd;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index a75353b..270f509 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -29,11 +29,11 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, lookupFixity ) import TcRnMonad -import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName, - mkInternalName, mkExternalName, mkIPName, nameSrcLoc, - nameOccName, setNameSrcLoc, nameModule ) +import Name ( Name, getName, nameIsLocalOrFrom, + isWiredInName, mkInternalName, mkExternalName, mkIPName, + nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) import NameSet -import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour ) +import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) import Module ( Module, ModuleName, moduleName, mkHomeModule, lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) import PrelNames ( mkUnboundName, intTyConName, @@ -49,7 +49,7 @@ import TysWiredIn ( unitTyCon ) -- A little odd import Finder ( findModule ) import FiniteMap import UniqSupply -import SrcLoc ( SrcLoc, noSrcLoc, importedSrcLoc ) +import SrcLoc ( SrcLoc, importedSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) import BasicTypes ( mapIPName, FixitySig(..) ) @@ -317,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name getGblEnv `thenM` \ gbl_env -> let avail_env = imp_env (tcg_imports gbl_env) + occ = rdrNameOcc rdr_name in - case lookupAvailEnv avail_env cls_name of + case lookupAvailEnv_maybe avail_env cls_name of Nothing -> -- If the class itself isn't in scope, then cls_name will -- be unboundName, and there'll already be an error for @@ -342,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name -- NB: qualified names are rejected by the parser lookupOrigName rdr_name - where - occ = rdrNameOcc rdr_name lookupSysBndr :: RdrName -> RnM Name -- Used for the 'system binders' in a data type or class declaration @@ -769,7 +768,7 @@ bindLocalsRn doc rdr_names enclosed_scope -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFVRn doc rdr_names enclosed_scope +bindLocalsFV doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> returnM (thing, delListFromNameSet fvs names) @@ -792,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replaceTyVarName tyvar_names names) -bindPatSigTyVars :: [RdrNameHsType] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) +bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope -bindPatSigTyVars tys enclosed_scope +bindPatSigTyVars tys thing_inside = getLocalRdrEnv `thenM` \ name_env -> getSrcLocM `thenM` \ loc -> let @@ -813,10 +810,15 @@ bindPatSigTyVars tys enclosed_scope located_tyvars = [(tv, loc) | tv <- forall_tyvars] doc_sig = text "In a pattern type-signature" in - bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> - enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs names) + bindLocatedLocalsRn doc_sig located_tyvars thing_inside +bindPatSigTyVarsFV :: [RdrNameHsType] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc @@ -890,10 +892,11 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs where occ = nameOccName name elt = GRE {gre_name = name, - gre_parent = parent, + gre_parent = if name == parent + then Nothing + else Just parent, gre_prov = mk_provenance name, gre_deprec = lookupDeprec deprecs name} - \end{code} \begin{code} @@ -986,44 +989,37 @@ warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mappM_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance - groups = equivClasses cmp names + groups = equivClasses cmp (filter reportable names) (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 + reportable (name,_) = reportIfUnused (nameOccName name) + ------------------------- warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () warnUnusedGroup names - | null filtered_names = returnM () - | not is_local = returnM () - | otherwise = addSrcLoc def_loc $ - addWarn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] + addWarn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))] where - filtered_names = filter reportable names - (name1, prov1) = head filtered_names - (is_local, def_loc, msg) - = case prov1 of - LocalDef -> (True, getSrcLoc name1, text "Defined but not used") - - NonLocalDef (UserImport mod loc _) - -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") - - reportable (name,_) = case occNameUserString (nameOccName name) of - ('_' : _) -> False - zz_other -> True - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". + (name1, prov1) = head names + loc1 = nameSrcLoc name1 + (def_loc, msg) = case prov1 of + LocalDef -> (loc1, unused_msg) + NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod) + + unused_msg = text "Defined but not used" + imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" \end{code} \begin{code} addNameClashErrRn rdr_name (np1:nps) = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]