X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=47595e2a89f1a94a9e8477d4fb598cc2de56dd63;hp=86f3d67fd4c99f8b792ae118de6b9327cef6638e;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 86f3d67..47595e2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -31,7 +31,9 @@ module RnEnv ( bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, - checkDupNames, checkShadowing, mapFvRn, mapFvRnCPS, + checkDupRdrNames, checkDupNames, checkShadowedNames, + checkDupAndShadowedRdrNames, + mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, @@ -45,27 +47,17 @@ import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, LHsTyVarBndr, LHsType, Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, - isQual_maybe, - mkRdrUnqual, setRdrNameSpace, rdrNameOcc, - pprGlobalRdrEnv, lookupGRE_RdrName, - isExact_maybe, isSrcRdrName, - Parent(..), - GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, - isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, - importSpecLoc, importSpecModule - ) +import RdrName import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, isExternalName ) + nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) import NameSet import NameEnv -import UniqFM +import LazyUniqFM import DataCon ( dataConFieldLabels ) -import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, +import OccName ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused, occNameFS ) import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) @@ -74,13 +66,34 @@ import BasicTypes ( IPName, mapIPName, Fixity ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable -import Util ( sortLe ) +import Util import Maybes import ListSetOps ( removeDups ) import List ( nubBy ) -import Monad ( when ) import DynFlags import FastString +import Control.Monad +\end{code} + +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM + +mappM_ :: (Monad m) => (a -> m b) -> [a] -> m () +mappM_ = mapM_ + +checkM :: Monad m => Bool -> m () -> m () +checkM = unless \end{code} %********************************************************* @@ -356,7 +369,7 @@ lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) getLookupOccRn :: RnM (Name -> Maybe Name) getLookupOccRn = getLocalRdrEnv `thenM` \ local_env -> - return (lookupLocalRdrEnv local_env . mkRdrUnqual . nameOccName) + return (lookupLocalRdrOcc local_env . nameOccName) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -553,7 +566,9 @@ bindLocalFixities fixes thing_inside Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix))) Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix))) - nowAndLater (ls :: [Either (Name, FixItem) (FastString, Located Fixity)]) = + nowAndLater :: [Either (Name, FixItem) (FastString, Located Fixity)] + -> ([(Name,FixItem)], UniqFM (Located Fixity)) + nowAndLater ls = foldr (\ cur -> \ (now, later) -> case cur of Left (n, f) -> ((n, f) : now, later) @@ -562,17 +577,23 @@ bindLocalFixities fixes thing_inside -- Used for nested fixity decls to bind names along with their fixities. -- the fixities are given as a UFM from an OccName's FastString to a fixity decl -bindLocalNamesFV_WithFixities :: [Name] -> UniqFM (Located Fixity) -> RnM (a, FreeVars) -> RnM (a, FreeVars) -bindLocalNamesFV_WithFixities names fixities cont = +-- Also check for unused binders +bindLocalNamesFV_WithFixities :: [Name] + -> UniqFM (Located Fixity) + -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV_WithFixities names fixities thing_inside + = bindLocalNamesFV names $ + extendFixityEnv boundFixities $ + thing_inside + where -- find the names that have fixity decls - let boundFixities = foldr + boundFixities = foldr (\ name -> \ acc -> -- check whether this name has a fixity decl case lookupUFM fixities (occNameFS (nameOccName name)) of Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc - Nothing -> acc) [] names in + Nothing -> acc) [] names -- bind the names; extend the fixity env; do the thing inside - bindLocalNamesFV names (extendFixityEnv boundFixities cont) \end{code} -------------------------------- @@ -738,23 +759,25 @@ newLocalsRn rdr_names_w_loc -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName mkInternalName uniq (rdrNameOcc rdr_name) loc +--------------------- +checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM () +checkDupAndShadowedRdrNames doc loc_rdr_names + = do { checkDupRdrNames doc loc_rdr_names + ; envs <- getRdrEnvs + ; checkShadowedNames doc envs + [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] } + +--------------------- bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [Located RdrName] + -> [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = -- Check for duplicate names - checkDupNames doc_str rdr_names_w_loc `thenM_` - - -- Warn about shadowing, but only in source modules - ifOptM Opt_WarnNameShadowing - (checkShadowing doc_str rdr_names_w_loc) `thenM_` + = checkDupAndShadowedRdrNames doc_str rdr_names_w_loc `thenM_` -- Make fresh Names and extend the environment - newLocalsRn rdr_names_w_loc `thenM` \ names -> - getLocalRdrEnv `thenM` \ local_env -> - setLocalRdrEnv (extendLocalRdrEnv local_env names) - (enclosed_scope names) + newLocalsRn rdr_names_w_loc `thenM` \names -> + bindLocalNames names (enclosed_scope names) bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope @@ -836,27 +859,41 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- +checkDupRdrNames :: SDoc + -> [Located RdrName] + -> RnM () +checkDupRdrNames doc_str rdr_names_w_loc + = -- Check for duplicated names in a binding group + mappM_ (dupNamesErr getLoc doc_str) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + checkDupNames :: SDoc - -> [Located RdrName] + -> [Name] -> RnM () -checkDupNames doc_str rdr_names_w_loc +checkDupNames doc_str names = -- Check for duplicated names in a binding group - mappM_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr nameSrcSpan doc_str) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names ------------------------------------- -checkShadowing doc_str loc_rdr_names - = getLocalRdrEnv `thenM` \ local_env -> - getGlobalRdrEnv `thenM` \ global_env -> - let - check_shadow (L loc rdr_name) - | rdr_name `elemLocalRdrEnv` local_env - || not (null (lookupGRE_RdrName rdr_name global_env )) - = addWarnAt loc (shadowedNameWarn doc_str rdr_name) - | otherwise = returnM () - in - mappM_ check_shadow loc_rdr_names +checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () +checkShadowedNames doc_str (global_env,local_env) loc_rdr_names + = ifOptM Opt_WarnNameShadowing $ + do { traceRn (text "shadow" <+> ppr loc_rdr_names) + ; mappM_ check_shadow loc_rdr_names } + where + check_shadow (loc, occ) + | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr loc] + | not (null gres) = complain (map pprNameProvenance gres) + | otherwise = return () + where + complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs) + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only \end{code} @@ -877,16 +914,13 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> -- because some of the rename functions are CPSed: -- maps the function across the list from left to right; -- collects all the free vars into one set -mapFvRnCPS :: (a -> ((b,FreeVars) -> RnM (c, FreeVars)) -> RnM(c, FreeVars)) - -> [a] - -> (([b],FreeVars) -> RnM (c, FreeVars)) - -> RnM (c, FreeVars) - -mapFvRnCPS _ [] cont = cont ([], emptyFVs) +mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c) + -> [a] -> ([b] -> RnM c) -> RnM c -mapFvRnCPS f (h:t) cont = f h $ \ (h',hfv) -> - mapFvRnCPS f t $ \ (t',tfv) -> - cont (h':t', hfv `plusFV` tfv) +mapFvRnCPS _ [] cont = cont [] +mapFvRnCPS f (x:xs) cont = f x $ \ x' -> + mapFvRnCPS f xs $ \ xs' -> + cont (x':xs') \end{code} @@ -914,9 +948,19 @@ warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () -warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) -warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches + +check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +check_unused flag names thing_inside + = do { (res, res_fvs) <- thing_inside + + -- Warn about unused names + ; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names)) + + -- And return + ; return (res, res_fvs) } ------------------------- -- Helpers @@ -967,10 +1011,10 @@ addNameClashErrRn rdr_name names msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn doc shadow - = hsep [ptext SLIT("This binding for"), - quotes (ppr shadow), - ptext SLIT("shadows an existing binding")] +shadowedNameWarn doc occ shadowed_locs + = sep [ptext SLIT("This binding for") <+> quotes (ppr occ) + <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] $$ doc unknownNameErr rdr_name @@ -986,14 +1030,13 @@ badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr :: SDoc -> [Located RdrName] -> RnM () -dupNamesErr descriptor located_names +dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM () +dupNamesErr get_loc descriptor names = addErrAt big_loc $ - vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr (head names)), locations, descriptor] where - L _ name1 = head located_names - locs = map getLoc located_names + locs = map get_loc names big_loc = foldr1 combineSrcSpans locs one_line = isOneLineSpan big_loc locations | one_line = empty