X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=551c6c48f5a89c7854b33ac05a445c1959ec26e5;hb=6cea635ae32abdb01aec6aae05477924b40c3148;hp=d9265832d730265bb36b1622d994323c58f61ca1;hpb=9c26739695219d8343505a88457cb55c76b65449;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index d926583..551c6c4 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -4,41 +4,37 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -#include "HsVersions.h" - module RnEnv where -- Export everything -IMPORT_1_3(List (nub)) -IMP_Ubiq() +#include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing ) +import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedNames ) import HsSyn -import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE), +import RdrHsSyn ( RdrName(..), RdrNameIE, rdrNameOcc, ieOcc, isQual, qual ) import HsTypes ( getTyVarName, replaceTyVarName ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..), pprModule ) import RnMonad -import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..), NamedThing(..), - occNameString, occNameFlavour, - SYN_IE(NameSet), emptyNameSet, addListToNameSet, - mkLocalName, mkGlobalName, modAndOcc, isLocallyDefinedName, - isWiredInName, nameOccName, setNameProvenance, isVarOcc, getNameProvenance, - pprProvenance, pprOccName, pprModule, pprNameProvenance +import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..), + occNameString, occNameFlavour, getSrcLoc, + NameSet, emptyNameSet, addListToNameSet, nameSetToList, + mkLocalName, mkGlobalName, modAndOcc, + nameOccName, setNameProvenance, isVarOcc, getNameProvenance, + pprProvenance, pprOccName, pprModule, pprNameProvenance, + isLocalName ) import TyCon ( TyCon ) import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon ) import FiniteMap -import Outputable -import Unique ( Unique, unboundKey ) -import UniqFM ( Uniquable(..), listToUFM, plusUFM_C ) +import Unique ( Unique, Uniquable(..), unboundKey ) +import UniqFM ( listToUFM, plusUFM_C ) import Maybes ( maybeToBool ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) -import Pretty -import Outputable ( PprStyle(..) ) -import Util --( panic, removeDups, pprTrace, assertPanic ) - +import Outputable +import Util ( removeDups ) +import List ( nub ) \end{code} @@ -50,29 +46,56 @@ import Util --( panic, removeDups, pprTrace, assertPanic ) %********************************************************* \begin{code} -newGlobalName :: Module -> OccName -> RnM s d Name -newGlobalName mod occ +newImportedGlobalName :: Module -> OccName + -> IfaceFlavour + -> RnM s d Name +newImportedGlobalName mod occ hif = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - let key = (mod,occ) in + let + key = (mod,occ) + prov = NonLocalDef noSrcLoc hif False + in case lookupFM cache key of - -- A hit in the cache! Return it, but change the src loc - -- of the thing we've found if this is a second definition site - -- (that is, if loc /= NoSrcLoc) - Just name -> returnRn name - - -- Miss in the cache, so build a new original name, - -- and put it in the cache - Nothing -> + -- A hit in the cache! + -- If it has no provenance at the moment then set its provenance + -- so that it has the right HiFlag component. + -- (This is necessary + -- for known-key things. For example, GHCmain.lhs imports as SOURCE + -- Main; but Main.main is a known-key thing.) + -- Don't fiddle with the provenance if it already has one + Just name -> case getNameProvenance name of + NoProvenance -> let + new_name = setNameProvenance name prov + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + other -> returnRn name + + Nothing -> -- Miss in the cache! + -- Build a new original name, and put it in the cache + let + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + name = mkGlobalName uniq mod occ prov + new_cache = addToFM cache key name + in + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn name + +{- let - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - name = mkGlobalName uniq mod occ VanillaDefn Implicit - cache' = addToFM cache key name + pprC ((mod,occ),name) = pprModule mod <> text "." <> pprOccName occ <+> text "--->" + <+> ppr name in - setNameSupplyRn (us', inst_ns, cache') `thenRn_` - returnRn name + pprTrace "ng" (vcat [text "newGlobalName miss" <+> pprModule mod <+> pprOccName occ, + brackets (sep (map pprC (fmToList cache))), + text "" + ]) $ +-} + newLocallyDefinedGlobalName :: Module -> OccName -> (Name -> ExportFlag) -> SrcLoc @@ -80,59 +103,34 @@ newLocallyDefinedGlobalName :: Module -> OccName newLocallyDefinedGlobalName mod occ rec_exp_fn loc = -- First check the cache getNameSupplyRn `thenRn` \ (us, inst_ns, cache) -> - - -- We are at the binding site for a locally-defined thing, so - -- you might think it can't be in the cache, but it can if it's a - -- wired in thing. In that case we need to use the correct unique etc... - -- so all we do is replace its provenance. - -- If it's not in the cache we put it there with the correct provenance. - -- The idea is that, after all this, the cache - -- will contain a Name with the correct Provenance (i.e. Local) - - -- OLD (now wrong) COMMENT: - -- "Actually, there's a catch. If this is the *second* binding for something - -- we want to allocate a *fresh* unique, rather than using the same Name as before. - -- Otherwise we don't detect conflicting definitions of the same top-level name! - -- So the only time we re-use a Name already in the cache is when it's one of - -- the Implicit magic-unique ones mentioned in the previous para" - - -- This (incorrect) patch doesn't work for record decls, when we have - -- the same field declared in multiple constructors. With the above patch, - -- each occurrence got a new Name --- aargh! - -- - -- So I reverted to the simple caching method (no "second-binding" thing) - -- The multiple-local-binding case is now handled by improving the conflict - -- detection in plusNameEnv. - let - provenance = LocalDef (rec_exp_fn new_name) loc - (us', us1) = splitUniqSupply us - uniq = getUnique us1 - key = (mod,occ) - new_name = case lookupFM cache key of - Just name -> setNameProvenance name provenance - other -> mkGlobalName uniq mod occ VanillaDefn provenance - new_cache = addToFM cache key new_name + let + key = (mod,occ) in - setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` - returnRn new_name - --- newSysName is used to create the names for --- a) default methods --- These are never mentioned explicitly in source code (hence no point in looking --- them up in the NameEnv), but when reading an interface file --- we may want to slurp in their pragma info. In the source file itself we --- need to create these names too so that we export them into the inferface file for this module. - -newSysName :: OccName -> ExportFlag -> SrcLoc -> RnMS s Name -newSysName occ export_flag loc - = getModeRn `thenRn` \ mode -> - getModuleRn `thenRn` \ mod_name -> - case mode of - SourceMode -> newLocallyDefinedGlobalName - mod_name occ - (\_ -> export_flag) - loc - InterfaceMode _ -> newGlobalName mod_name occ + case lookupFM cache key of + + -- A hit in the cache! + -- Overwrite whatever provenance is in the cache already; + -- this updates WiredIn things and known-key things, + -- which are there from the start, to LocalDef. + Just name -> let + new_name = setNameProvenance name (LocalDef loc (rec_exp_fn new_name)) + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us, inst_ns, new_cache) `thenRn_` + returnRn new_name + + -- Miss in the cache! + -- Build a new original name, and put it in the cache + Nothing -> let + provenance = LocalDef loc (rec_exp_fn new_name) + (us', us1) = splitUniqSupply us + uniq = getUnique us1 + new_name = mkGlobalName uniq mod occ provenance + new_cache = addToFM cache key new_name + in + setNameSupplyRn (us', inst_ns, new_cache) `thenRn_` + returnRn new_name + -- newDfunName is a variant, specially for dfuns. -- When renaming derived definitions we are in *interface* mode (because we can trip @@ -150,7 +148,7 @@ newDfunName Nothing src_loc -- Local instance decls have a "Nothing" newDfunName (Just n) src_loc -- Imported ones have "Just n" = getModuleRn `thenRn` \ mod_name -> - newGlobalName mod_name (rdrNameOcc n) + newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -} newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name] @@ -177,14 +175,14 @@ isUnboundName name = uniqueOf name == unboundKey \end{code} \begin{code} -bindLocatedLocalsRn :: (PprStyle -> Doc) -- Documentation string for error message +bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] -> ([Name] -> RnMS s a) -> RnMS s a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - getNameEnv `thenRn` \ name_env -> + getLocalNameEnv `thenRn` \ name_env -> (if opt_WarnNameShadowing then mapRn (check_shadow name_env) rdr_names_w_loc @@ -196,7 +194,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope let new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names) in - setNameEnv new_name_env (enclosed_scope names) + setLocalNameEnv new_name_env (enclosed_scope names) where check_shadow name_env (rdr_name,loc) = case lookupFM name_env rdr_name of @@ -206,7 +204,7 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope bindLocalsRn doc_str rdr_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn (\_ -> text doc_str) + bindLocatedLocalsRn (text doc_str) (rdr_names `zip` repeat loc) enclosed_scope @@ -219,7 +217,7 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope enclosed_scope (zipWith replaceTyVarName tyvar_names names) -- Works in any variant of the renamer monad -checkDupOrQualNames, checkDupNames :: (PprStyle -> Doc) +checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] -> RnM s d () @@ -235,7 +233,13 @@ checkDupNames doc_str rdr_names_w_loc mapRn (dupNamesErr doc_str) dups `thenRn_` returnRn () where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc + (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc + + +-- Yuk! +ifaceFlavour name = case getNameProvenance name of + NonLocalDef _ hif _ -> hif + other -> HiFile -- Shouldn't happen \end{code} @@ -248,37 +252,69 @@ checkDupNames doc_str rdr_names_w_loc Looking up a name in the RnEnv. \begin{code} -lookupRn :: NameEnv -> RdrName -> RnMS s Name -lookupRn name_env rdr_name - = case lookupFM name_env rdr_name of - - -- Found it! - Just name -> returnRn name - - -- Not found - Nothing -> getModeRn `thenRn` \ mode -> - case mode of - -- Not found when processing source code; so fail - SourceMode -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - - -- Not found when processing an imported declaration, - -- so we create a new name for the purpose - InterfaceMode _ -> - case rdr_name of - - Qual mod_name occ -> newGlobalName mod_name occ - - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - Unqual occ -> getModuleRn `thenRn ` \ mod_name -> - newGlobalName mod_name occ - +lookupRn :: RdrName + -> Maybe Name -- Result of environment lookup + -> RnMS s 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 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 + + InterfaceMode _ _ -> + + + ---------------------------------------------------- + -- OK, so we're in interface mode + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + -- 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 + + } lookupBndrRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name + = lookupNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + + if isLocalName name then + returnRn name + else + + ---------------------------------------------------- + -- OK, so we're at the binding site of a top-level defn + -- Check to see whether its an imported decl + getModeRn `thenRn` \ mode -> + case mode of { + SourceMode -> returnRn name ; + + InterfaceMode _ print_unqual_fn -> + + ---------------------------------------------------- + -- OK, the binding site of an *imported* defn + -- so we can make the provenance more informative + getSrcLocRn `thenRn` \ src_loc -> + let + name' = case getNameProvenance name of + NonLocalDef _ hif _ -> setNameProvenance name + (NonLocalDef src_loc hif (print_unqual_fn name')) + other -> name + in + returnRn name' + } -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. @@ -286,19 +322,38 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = getNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name + = lookupNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + let + name' = mungePrintUnqual rdr_name name + in + addOccurrenceName name' -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. It's used for record field names only. +-- environment only. It's used for record field names only. lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn rdr_name - = getGlobalNameEnv `thenRn` \ name_env -> - lookupRn name_env rdr_name `thenRn` \ name -> - addOccurrenceName name - - + = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> + lookupRn rdr_name maybe_name `thenRn` \ name -> + let + name' = mungePrintUnqual rdr_name name + in + addOccurrenceName name' + +-- mungePrintUnqual is used to make *imported* *occurrences* print unqualified +-- if they were mentioned unqualified in the source code. +-- This improves error messages from the type checker. +-- NB: the binding site is treated differently; see lookupBndrRn +-- After the type checker all occurrences are replaced by the one +-- at the binding site. +mungePrintUnqual (Qual _ _ _) name = name +mungePrintUnqual (Unqual _) name = case new_prov of + Nothing -> name + Just prov' -> setNameProvenance name prov' + where + new_prov = case getNameProvenance name of + NonLocalDef loc hif False -> Just (NonLocalDef loc hif True) + other -> Nothing -- lookupImplicitOccRn takes an RdrName representing an *original* name, and -- adds it to the occurrence pool so that it'll be loaded later. This is @@ -310,6 +365,7 @@ lookupGlobalOccRn rdr_name -- we don't check for this case: it does no harm to record an "extra" occurrence -- and lookupImplicitOccRn isn't used much in interface mode (it's only the -- Nothing clause of rnDerivs that calls it at all I think). +-- [Jan 98: this comment is wrong: rnHsType uses it quite a bit.] -- -- For List and Tuple types it's important to get the correct -- isLocallyDefined flag, which is used in turn when deciding @@ -317,8 +373,8 @@ lookupGlobalOccRn rdr_name -- The name cache should have the correct provenance, though. lookupImplicitOccRn :: RdrName -> RnMS s Name -lookupImplicitOccRn (Qual mod occ) - = newGlobalName mod occ `thenRn` \ name -> +lookupImplicitOccRn (Qual mod occ hif) + = newImportedGlobalName mod occ hif `thenRn` \ name -> addOccurrenceName name addImplicitOccRn :: Name -> RnMS s Name @@ -342,7 +398,20 @@ lookupFixity rdr_name returnRn (lookupFixityEnv fixity_env rdr_name) \end{code} +mkImportFn returns a function that takes a Name and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the Name's provenance to guide whether or not to print the name qualified +in error messages. +\begin{code} +mkImportFn :: RnEnv -> Name -> Bool +mkImportFn (RnEnv env _) + = lookup + where + lookup name = case lookupFM env (Unqual (nameOccName name)) of + Just (name', _) -> name == name' + Nothing -> False +\end{code} %************************************************************************ %* * @@ -353,41 +422,44 @@ lookupFixity rdr_name =============== RnEnv ================ \begin{code} plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2) - = plusNameEnvRn n1 n2 `thenRn` \ n -> - plusFixityEnvRn f1 f2 `thenRn` \ f -> + = plusGlobalNameEnvRn n1 n2 `thenRn` \ n -> + plusFixityEnvRn f1 f2 `thenRn` \ f -> returnRn (RnEnv n f) \end{code} + =============== NameEnv ================ \begin{code} -plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv -plusNameEnvRn env1 env2 +plusGlobalNameEnvRn :: GlobalNameEnv -> GlobalNameEnv -> RnM s d GlobalNameEnv +plusGlobalNameEnvRn env1 env2 = mapRn (addErrRn.nameClashErr) (conflictsFM conflicting_name env1 env2) `thenRn_` returnRn (env1 `plusFM` env2) -addOneToNameEnv :: NameEnv -> RdrName -> Name -> RnM s d NameEnv -addOneToNameEnv env rdr_name name +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_` returnRn env - Nothing -> returnRn (addToFM env rdr_name name) + other -> returnRn (addToFM env rdr_name name) -conflicting_name n1 n2 = (n1 /= n2) || (isLocallyDefinedName n1 && isLocallyDefinedName n2) +delOneFromGlobalNameEnv :: GlobalNameEnv -> RdrName -> GlobalNameEnv +delOneFromGlobalNameEnv env rdr_name = delFromFM env rdr_name + +conflicting_name :: (Name, HowInScope) -> (Name, HowInScope) -> Bool +conflicting_name (n1, FromLocalDefn _) (n2, FromLocalDefn _) = True +conflicting_name (n1,h1) (n2,h2) = n1 /= n2 -- We complain of a conflict if one RdrName maps to two different Names, -- OR if one RdrName maps to the same *locally-defined* Name. The latter -- case is to catch two separate, local definitions of the same thing. -- -- If a module imports itself then there might be a local defn and an imported -- defn of the same name; in this case the names will compare as equal, but - -- will still have different provenances. + -- will still have different HowInScope fields lookupNameEnv :: NameEnv -> RdrName -> Maybe Name lookupNameEnv = lookupFM - -delOneFromNameEnv :: NameEnv -> RdrName -> NameEnv -delOneFromNameEnv env rdr_name = delFromFM env rdr_name \end{code} =============== FixityEnv ================ @@ -403,25 +475,38 @@ lookupFixityEnv env rdr_name Just (fixity,_) -> fixity Nothing -> Fixity 9 InfixL -- Default case -bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool +bad_fix :: (Fixity, HowInScope) -> (Fixity, HowInScope) -> Bool bad_fix (f1,_) (f2,_) = f1 /= f2 -pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Doc -pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov +pprFixityProvenance :: (Fixity, HowInScope) -> SDoc +pprFixityProvenance (fixity, how_in_scope) = ppr how_in_scope \end{code} -=============== Avails ================ +=============== ExportAvails ================ \begin{code} -mkExportAvails :: Bool -> Module -> [AvailInfo] -> ExportAvails -mkExportAvails unqualified_import mod_name avails +mkExportAvails :: Module -> Bool -> GlobalNameEnv -> [AvailInfo] -> ExportAvails +mkExportAvails mod_name unqual_imp name_env avails = (mod_avail_env, entity_avail_env) where - -- The "module M" syntax only applies to *unqualified* imports (1.4 Report, Section 5.1.1) - mod_avail_env | unqualified_import = unitFM mod_name avails - | otherwise = emptyFM - + mod_avail_env = unitFM mod_name unqual_avails + + -- unqual_avails is the Avails that are visible in *unqualfied* form + -- (1.4 Report, Section 5.1.1) + -- For example, in + -- import T hiding( f ) + -- we delete f from avails + + unqual_avails | not unqual_imp = [] -- Short cut when no unqualified imports + | otherwise = [prune avail | avail <- avails] + + prune (Avail n) | unqual_in_scope n = Avail n + prune (Avail n) | otherwise = NotAvailable + prune (AvailTC n ns) = AvailTC n (filter unqual_in_scope ns) + + unqual_in_scope n = Unqual (nameOccName n) `elemFM` name_env + entity_avail_env = listToUFM [ (name,avail) | avail <- avails, name <- availEntityNames avail] @@ -439,7 +524,7 @@ plusAvail a NotAvailable = a plusAvail NotAvailable a = a -- Added SOF 4/97 #ifdef DEBUG -plusAvail a1 a2 = panic ("RnEnv.plusAvail " ++ (show (hsep [pprAvail PprDebug a1,pprAvail PprDebug a2]))) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) #endif addAvailToNameSet :: NameSet -> AvailInfo -> NameSet @@ -476,7 +561,7 @@ filterAvail :: RdrNameIE -- Wanted filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (hsep [ppr PprDebug ie, pprAvail PprDebug avail]) $ + | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs @@ -484,8 +569,8 @@ filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) avail_occs = map nameOccName ns wanted_occs = map rdrNameOcc (want:wants) -filterAvail (IEThingAbs _) (AvailTC n ns) - | n `elem` ns = AvailTC n [n] +filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) + AvailTC n [n] filterAvail (IEThingAbs _) avail@(Avail n) = avail -- Type synonyms @@ -504,8 +589,11 @@ filterAvail ie avail = NotAvailable -- In interfaces, pprAvail gets given the OccName of the "host" thing -pprAvail PprInterface avail = ppr_avail (pprOccName PprInterface . nameOccName) avail -pprAvail sty avail = ppr_avail (ppr sty) avail +pprAvail avail = getPprStyle $ \ sty -> + if ifaceStyle sty then + ppr_avail (pprOccName . nameOccName) avail + else + ppr_avail ppr avail ppr_avail pp_name NotAvailable = ptext SLIT("NotAvailable") ppr_avail pp_name (AvailTC n ns) = hsep [ @@ -540,11 +628,11 @@ conflictsFM bad fm1 fm2 conflictFM :: Ord a => (b->b->Bool) -> FiniteMap a b -> a -> b - -> [(a,(b,b))] + -> Maybe (a,(b,b)) conflictFM bad fm key elt = case lookupFM fm key of - Just elt' | bad elt elt' -> [(key,(elt,elt'))] - other -> [] + Just elt' | bad elt elt' -> Just (key,(elt,elt')) + other -> Nothing \end{code} @@ -556,37 +644,48 @@ conflictFM bad fm key elt \begin{code} -nameClashErr (rdr_name, (name1,name2)) sty - = hang (hsep [ptext SLIT("Conflicting definitions for:"), ppr sty rdr_name]) - 4 (vcat [pprNameProvenance sty name1, - pprNameProvenance sty name2]) +warnUnusedNames :: NameSet -> RnM s d () +warnUnusedNames names + | not opt_WarnUnusedNames = returnRn () + | otherwise = 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]) -fixityClashErr (rdr_name, (fp1,fp2)) sty - = hang (hsep [ptext SLIT("Conflicting fixities for:"), ppr sty rdr_name]) - 4 (vcat [pprFixityProvenance sty fp1, - pprFixityProvenance sty fp2]) +fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) + = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) + 4 (vcat [ppr how_in_scope1, + ppr how_in_scope2]) -shadowedNameWarn shadow sty +shadowedNameWarn shadow = hcat [ptext SLIT("This binding for"), - ppr sty shadow, + quotes (ppr shadow), ptext SLIT("shadows an existing binding")] -unknownNameErr name sty - = sep [text flavour, ptext SLIT("not in scope:"), ppr sty name] +unknownNameErr name + = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (\sty -> hsep [ ptext SLIT("Invalid use of qualified name"), - ppr sty name, - ptext SLIT("in"), - descriptor sty]) + addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), + quotes (ppr name), + ptext SLIT("in"), + descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ - addErrRn (\sty -> hsep [ptext SLIT("Conflicting definitions for"), - ppr sty name, - ptext SLIT("in"), descriptor sty]) + addErrRn (hsep [ptext SLIT("Conflicting definitions for"), + quotes (ppr name), + ptext SLIT("in"), descriptor]) \end{code}