X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=47595e2a89f1a94a9e8477d4fb598cc2de56dd63;hp=933de84ff0bd90a94880de08beb081d012b5a141;hb=d51f42f602bf9a6d1b356c41228a534c88723f65;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 933de84..47595e2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,4 +1,4 @@ -% +\% % (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 % \section[RnEnv]{Environment manipulation for the renamer monad} @@ -13,25 +13,27 @@ module RnEnv ( newTopSrcBinder, lookupFamInstDeclBndr, - lookupLocatedBndrRn, lookupBndrRn, - lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedBndrRn, lookupBndrRn, lookupBndrRn_maybe, + lookupLocatedTopBndrRn, lookupTopBndrRn, lookupBndrRn_maybe, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, - lookupGreRn, lookupGreRn_maybe, + lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, newLocalsRn, newIPNameRn, - bindLocalNames, bindLocalNamesFV, + bindLocalNames, bindLocalNamesFV, bindLocalNamesFV_WithFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, - checkDupNames, mapFvRn, + checkDupRdrNames, checkDupNames, checkShadowedNames, + checkDupAndShadowedRdrNames, + mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, @@ -45,40 +47,53 @@ 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 HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +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 LazyUniqFM import DataCon ( dataConFieldLabels ) -import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, - reportIfUnused ) +import OccName ( OccName, tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, + reportIfUnused, occNameFS ) import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply -import BasicTypes ( IPName, mapIPName ) +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} %********************************************************* @@ -150,17 +165,31 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name +lookupBndrRn n = do nopt <- lookupBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n + +lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn $ text "lookupTopBndrRn" + unboundName n + +lookupBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd -lookupBndrRn rdr_name +lookupBndrRn_maybe rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of - Just name -> returnM name - Nothing -> lookupTopBndrRn rdr_name + Just name -> returnM (Just name) + Nothing -> lookupTopBndrRn_maybe rdr_name lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK: @@ -177,24 +206,23 @@ lookupTopBndrRn :: RdrName -> RnM Name -- The Haskell parser checks for the illegal qualified name in Haskell -- source files, so we don't need to do so here. -lookupTopBndrRn rdr_name +lookupTopBndrRn_maybe rdr_name | Just name <- isExact_maybe rdr_name - = returnM name + = returnM (Just name) | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder rdr_mod rdr_occ loc } + ; n <- newGlobalBinder rdr_mod rdr_occ loc + ; return (Just n)} | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name ; case mb_gre of - Nothing -> do - traceRn $ text "lookupTopBndrRn" - unboundName rdr_name - Just gre -> returnM (gre_name gre) } + Nothing -> returnM Nothing + Just gre -> returnM (Just $ gre_name gre) } -- lookupLocatedSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -281,7 +309,7 @@ lookupConstructorFields con_name ; if nameIsLocalOrFrom this_mod con_name then do { field_env <- getRecFieldEnv ; return (lookupNameEnv field_env con_name `orElse` []) } - else + else do { con <- tcLookupDataCon con_name ; return (dataConFieldLabels con) } } @@ -341,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 @@ -510,24 +538,62 @@ lookupLocalDataTcNames rdr_name | otherwise = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) ; case [gre_name gre | Just gre <- mb_gres] of - [] -> do { addErr (unknownNameErr rdr_name) - ; return [] } + [] -> do { + -- run for error reporting + ; unboundName rdr_name + ; return [] } names -> return names } -------------------------------- -bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a --- Used for nested fixity decls +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 but we don't +-- Should check for duplicates? bindLocalFixities fixes thing_inside - | null fixes = thing_inside - | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> - extendFixityEnv new_bit 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) - = addLocM lookupBndrRn lv `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) + 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 + +-- 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) + -> 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 + 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 + -- bind the names; extend the fixity env; do the thing inside \end{code} -------------------------------- @@ -547,13 +613,13 @@ lookupFixity is a bit strange. \begin{code} lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModule `thenM` \ this_mod -> + = getModule `thenM` \ this_mod -> if nameIsLocalOrFrom this_mod name - then -- It's defined in this module - getFixityEnv `thenM` \ local_fix_env -> - traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` - returnM (lookupFixity local_fix_env name) - + then do -- It's defined in this module + local_fix_env <- getFixityEnv + traceRn (text "lookupFixityRn: looking up name in local environment:" <+> + vcat [ppr name, ppr local_fix_env]) + return $ lookupFixity local_fix_env name else -- It's imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -571,8 +637,11 @@ lookupFixityRn name -- -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadInterfaceForName doc name `thenM` \ iface -> - returnM (mi_fix_fn iface (nameOccName name)) + loadInterfaceForName doc name `thenM` \ iface -> do { + traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); + returnM (mi_fix_fn iface (nameOccName name)) + } where doc = ptext SLIT("Checking fixity for") <+> ppr name @@ -690,24 +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 @@ -724,8 +794,8 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) - -> RnM (a, FreeVars) +bindLocatedLocalsFV :: SDoc -> [Located RdrName] + -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) bindLocatedLocalsFV doc rdr_names enclosed_scope = bindLocatedLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> @@ -789,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} @@ -826,6 +910,17 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> (ys, fvs_s) = unzip stuff in returnM (ys, plusFVs fvs_s) + +-- 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 -> RnM c) -> RnM c) + -> [a] -> ([b] -> RnM c) -> RnM c + +mapFvRnCPS _ [] cont = cont [] +mapFvRnCPS f (x:xs) cont = f x $ \ x' -> + mapFvRnCPS f xs $ \ xs' -> + cont (x':xs') \end{code} @@ -853,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 @@ -906,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 @@ -925,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