X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=f6f725ff15c8ab88db3d2e1ecdeed32fb871a83e;hb=400660fe4b6d0ec8c20ecc9d0a95dbb9ec5a5385;hp=59451fc535252ad0a2f0ecdd4d7c0f262aab1b1b;hpb=d19a72ea089deab3aa4bb584e69c102daebb1cb4;p=ghc-hetmet.git diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 59451fc..f6f725f 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -25,11 +25,12 @@ module RnEnv ( getLookupOccRn, newLocalsRn, newIPNameRn, - bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, + bindLocalNames, bindLocalNamesFV, + MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalFixities, checkDupRdrNames, checkDupNames, checkShadowedNames, checkDupAndShadowedRdrNames, @@ -57,8 +58,7 @@ import NameSet import NameEnv import LazyUniqFM import DataCon ( dataConFieldLabels ) -import OccName ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, - reportIfUnused, occNameFS ) +import OccName import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey, forall_tv_RDR ) @@ -528,59 +528,36 @@ lookupQualifiedName rdr_name %********************************************************* \begin{code} -lookupLocalDataTcNames :: RdrName -> RnM [Name] --- GHC extension: look up both the tycon and data con --- for con-like things --- Complain if neither is in scope -lookupLocalDataTcNames rdr_name - | Just n <- isExact_maybe rdr_name - -- Special case for (:), which doesn't get into the GlobalRdrEnv - = return [n] -- For this we don't need to try the tycon too - | otherwise - = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) - ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { - -- run for error reporting - ; unboundName rdr_name - ; return [] } - names -> return names - } +-------------------------------- +type FastStringEnv a = UniqFM a -- Keyed by FastString + + +emptyFsEnv :: FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a + +emptyFsEnv = emptyUFM +lookupFsEnv = lookupUFM +extendFsEnv = addToUFM -------------------------------- -bindLocalFixities :: [FixitySig RdrName] -> (UniqFM (Located Fixity) -> RnM a) -> RnM a --- Used for nested fixity decls: --- bind the names that are in scope already; --- pass the rest to the continuation for later --- as a FastString->(Located Fixity) map --- --- No need to worry about type constructors here, --- Should check for duplicates? -bindLocalFixities fixes thing_inside - | null fixes = thing_inside emptyUFM - | otherwise = do ls <- mappM rn_sig fixes - let (now, later) = nowAndLater ls - extendFixityEnv now $ thing_inside later - where - rn_sig (FixitySig lv@(L loc v) fix) = do - vopt <- lookupBndrRn_maybe v - case vopt of - Just new_v -> returnM (Left (new_v, (FixItem (rdrNameOcc v) fix))) - Nothing -> returnM (Right (occNameFS $ rdrNameOcc v, (L loc fix))) - - 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) - Right (fs, f) -> (now, addToUFM later fs f)) - ([], emptyUFM) ls +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly +-------------------------------- -- 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 -- Also check for unused binders bindLocalNamesFV_WithFixities :: [Name] - -> UniqFM (Located Fixity) + -> MiniFixityEnv -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV_WithFixities names fixities thing_inside = bindLocalNamesFV names $ @@ -591,7 +568,7 @@ bindLocalNamesFV_WithFixities names fixities thing_inside boundFixities = foldr (\ name -> \ acc -> -- check whether this name has a fixity decl - case lookupUFM fixities (occNameFS (nameOccName name)) of + case lookupFsEnv fixities (occNameFS (nameOccName name)) of Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc Nothing -> acc) [] names -- bind the names; extend the fixity env; do the thing inside @@ -651,6 +628,24 @@ lookupTyFixityRn :: Located Name -> RnM Fixity lookupTyFixityRn (L loc n) = lookupFixityRn n --------------- +lookupLocalDataTcNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +-- Complain if neither is in scope +lookupLocalDataTcNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; case [gre_name gre | Just gre <- mb_gres] of + [] -> do { + -- run for error reporting + ; unboundName rdr_name + ; return [] } + names -> return names + } + dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are @@ -886,7 +881,7 @@ checkShadowedNames doc_str (global_env,local_env) 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] + | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)] | not (null gres) = complain (map pprNameProvenance gres) | otherwise = return () where @@ -949,19 +944,13 @@ warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () 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) } +check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers