X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=6835f93a45007e38a8617bee943cc9e67ff3bda5;hb=c43a63d313214dbe0e1fe1d3fd2d982edff66cb1;hp=fc262edd3e94342a87f66ac710b02b3137d4c52b;hpb=787f32866ccf115271f8eafb22f44b0f4b13e7b6;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index fc262ed..6835f93 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,37 +10,53 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles -import HscTypes ( ModIface(..) ) import HsSyn -import RdrHsSyn ( RdrNameIE ) +import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv + mkRdrUnqual, mkRdrQual, + lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, + unqualifyRdrName ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) ) + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), + Deprecations(..), lookupDeprec, + extendLocalRdrEnv + ) import RnMonad -import Name ( Name, - getSrcLoc, +import Name ( Name, + getSrcLoc, nameIsLocalOrFrom, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) -import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) +import NameEnv import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, - WhereFrom(..) ) + mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) +import PrelNames ( mkUnboundName, + derivingOccurrences, + mAIN_Name, pREL_MAIN_Name, + ioTyConName, intTyConName, + boolTyConName, funTyConName, + unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + eqStringName, printName, + bindIOName, returnIOName, failIOName + ) +import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) +import BasicTypes ( mapIPName ) import List ( nub ) -import PrelNames ( mkUnboundName ) +import UniqFM ( lookupWithDefaultUFM ) +import Maybe ( mapMaybe ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -62,12 +78,11 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name newTopBinder mod rdr_name loc = -- First check the cache - -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_` -- There should never be a qualified name in a binding position (except in instance decls) -- The parser doesn't check this because the same parser parses instance decls (if isQual rdr_name then - qualNameErr (text "its declaration") (rdr_name,loc) + qualNameErr (text "In its declaration") (rdr_name,loc) else returnRn () ) `thenRn_` @@ -92,7 +107,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! @@ -106,7 +121,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -148,21 +163,24 @@ newGlobalName mod_name occ name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name -newIPName rdr_name +newIPName rdr_name_ip = getNameSupplyRn `thenRn` \ name_supply -> let ipcache = nsIPs name_supply in case lookupFM ipcache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_` - returnRn name + Just name_ip -> returnRn name_ip + Nothing -> setNameSupplyRn new_ns `thenRn_` + returnRn name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - name = mkIPName uniq key - new_ipcache = addToFM ipcache key name - where key = (rdrNameOcc rdr_name) + name_ip = mapIPName mk_name rdr_name_ip + mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name) + new_ipcache = addToFM ipcache key name_ip + new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} + where + key = rdr_name_ip -- Ensures that ?x and %x get distinct Names \end{code} %********************************************************* @@ -181,16 +199,38 @@ lookupBndrRn rdr_name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name +-- Look up a top-level local binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- So we have to filter out the non-local ones. +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. + + | isOrig rdr_name + -- This is here just to catch the PrelBase defn of (say) [] and similar + -- The parser reads the special syntax and returns an Orig RdrName + -- But the global_env contains only Qual RdrNames, so we won't + -- find it there; instead just get the name via the Orig route + = lookupOrigName rdr_name + + | otherwise = getModeRn `thenRn` \ mode -> if isInterfaceMode mode then lookupIfaceName rdr_name - else -- Source mode, so look up a *qualified* version - -- of the name, so that we get the right one even - -- if there are many with the same occ name - -- There must *be* a binding - getModuleRn `thenRn` \ mod -> - getGlobalNameEnv `thenRn` \ global_env -> - lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name) + else + getModuleRn `thenRn` \ mod -> + getGlobalNameEnv `thenRn` \ global_env -> + case lookup_local mod global_env rdr_name of + Just name -> returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + where + lookup_local mod global_env rdr_name + = case lookupRdrEnv global_env rdr_name of + Nothing -> Nothing + Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of + [] -> Nothing + (n:ns) -> Just n + -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -205,6 +245,33 @@ lookupTopBndrRn rdr_name lookupSigOccRn :: RdrName -> RnMS Name lookupSigOccRn = lookupBndrRn +-- lookupInstDeclBndr is used for the binders in an +-- instance declaration. Here we use the class name to +-- disambiguate. + +lookupInstDeclBndr :: Name -> RdrName -> RnMS Name + -- We use the selector name as the binder +lookupInstDeclBndr cls_name rdr_name + | isOrig rdr_name -- Occurs in derived instances, where we just + -- refer diectly to the right method + = lookupOrigName rdr_name + + | otherwise + = getGlobalAvails `thenRn` \ avail_env -> + case lookupNameEnv avail_env cls_name of + -- The class itself isn't in scope, so cls_name is unboundName + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + Nothing -> returnRn (mkUnboundName rdr_name) + Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of + (n:ns)-> ASSERT( null ns ) returnRn n + [] -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) + where + occ = rdrNameOcc rdr_name + -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name @@ -253,7 +320,7 @@ lookupQualifiedName rdr_name mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod ImportBySystem `thenRn` \ iface -> + loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> case [ name | (_,avails) <- mi_exports iface, avail <- avails, name <- availNames avail, @@ -269,11 +336,13 @@ lookupSrcName global_env rdr_name | otherwise = case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn name - Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + Just [GRE name _ Nothing] -> returnRn name + Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` + returnRn name + Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) lookupOrigName :: RdrName -> RnM d Name lookupOrigName rdr_name @@ -332,6 +401,97 @@ lookupSysBinder rdr_name %********************************************************* %* * +\subsection{Implicit free vars and sugar names} +%* * +%********************************************************* + +@getXImplicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +getImplicitStmtFVs -- Compiling a statement + = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName] + `plusFV` ubiquitousNames) + -- These are all needed implicitly when compiling a statement + -- See TcModule.tc_stmts + +getImplicitModuleFVs mod_name decls -- Compiling a module + = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> + returnRn (deriving_names `plusFV` implicit_main `plusFV` ubiquitousNames) + where + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyConName + | otherwise = emptyFVs + + -- deriv_classes is now a list of HsTypes, so a "normal" one + -- appears as a (HsClassP c []). The non-normal ones for the new + -- newtype-deriving extension, and they don't require any + -- implicit names, so we can silently filter them out. + deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, + HsClassP cls [] <- deriv_classes, + occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] + +-- ubiquitous_names are loaded regardless, because +-- they are needed in virtually every program +ubiquitousNames + = mkFVs [unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName] + -- Virtually every program has error messages in it somewhere + + `plusFV` + mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName] + -- Add occurrences for very frequently used types. + -- (e.g. we don't want to be bothered with making funTyCon a + -- free var at every function application!) +\end{code} + +%************************************************************************ +%* * +\subsection{Re-bindable desugaring names} +%* * +%************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional + * NegApp + * NPlusKPatIn +respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. + +\begin{code} +lookupSyntaxName :: Name -- The standard name + -> RnMS Name -- Possibly a non-standard name +lookupSyntaxName std_name + = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + if not no_prelude then + returnRn std_name -- Normal case + else + let + rdr_name = mkRdrUnqual (nameOccName std_name) + -- Get the similarly named thing from the local environment + in + lookupOccRn rdr_name +\end{code} + + +%********************************************************* +%* * \subsection{Binding} %* * %********************************************************* @@ -342,9 +502,8 @@ newLocalsRn :: [(RdrName,SrcLoc)] newLocalsRn rdr_names_w_loc = getNameSupplyRn `thenRn` \ name_supply -> let - n = length rdr_names_w_loc (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniqs = uniqsFromSupply n us1 + uniqs = uniqsFromSupply us1 names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] @@ -359,32 +518,34 @@ bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> RnMS a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ name_env -> + getLocalNameEnv `thenRn` \ local_env -> + getGlobalNameEnv `thenRn` \ global_env -> -- Check for duplicate names checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow -> - -- Warn about shadowing, but only in source modules + let + check_shadow (rdr_name,loc) + | rdr_name `elemRdrEnv` local_env + || rdr_name `elemRdrEnv` global_env + = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + | otherwise + = returnRn () + in + (case mode of - SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc - other -> returnRn () + SourceMode -> ifOptRn Opt_WarnNameShadowing $ + mapRn_ check_shadow rdr_names_w_loc + other -> returnRn () ) `thenRn_` - + newLocalsRn rdr_names_w_loc `thenRn` \ names -> let - new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) + new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) in setLocalNameEnv new_local_env (enclosed_scope names) - where - check_shadow name_env (rdr_name,loc) - = case lookupRdrEnv name_env rdr_name of - Nothing -> returnRn () - Just name -> pushSrcLocRn loc $ - addWarnRn (shadowedNameWarn rdr_name) - bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) @@ -414,10 +575,8 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> bindLocalNames names enclosed_scope = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (addListToRdrEnv name_env pairs) + setLocalNameEnv (extendLocalRdrEnv name_env names) enclosed_scope - where - pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] bindLocalNamesFV names enclosed_scope = bindLocalNames names $ @@ -456,47 +615,36 @@ bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] -> ([HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope - = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> - enclosed_scope tyvars - --- Gruesome name: return Names as well as HsTyVars -bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName] - -> ([Name] -> [HsTyVarBndr Name] -> RnMS a) - -> RnMS a -bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> let located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope names (zipWith replaceTyVarName tyvar_names names) - -bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) -bindTyVarsFVRn doc_str rdr_names enclosed_scope - = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> - enclosed_scope tyvars `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope (zipWith replaceTyVarName tyvar_names names) -bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName] - -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) -bindTyVarsFV2Rn doc_str rdr_names enclosed_scope - = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> - enclosed_scope names tyvars `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) +bindPatSigTyVars :: [RdrNameHsType] + -> RnMS (a, FreeVars) + -> RnMS (a, FreeVars) + -- Find the type variables in the pattern type + -- signatures that must be brought into scope -bindNakedTyVarsFVRn :: SDoc -> [RdrName] - -> ([Name] -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) -bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> +bindPatSigTyVars tys enclosed_scope + = getLocalNameEnv `thenRn` \ name_env -> + getSrcLocRn `thenRn` \ loc -> let - located_tyvars = [(tv, loc) | tv <- tyvar_names] + forall_tyvars = nub [ tv | ty <- tys, + tv <- extractHsTyRdrTyVars ty, + not (tv `elemFM` name_env) + ] + -- The 'nub' is important. For example: + -- f (x :: t) (y :: t) = .... + -- We don't want to complain about binding t twice! + + located_tyvars = [(tv, loc) | tv <- forall_tyvars] + doc_sig = text "In a pattern type-signature" in - bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope names `thenRn` \ (thing, fvs) -> + bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> + enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) @@ -530,14 +678,12 @@ checkDupNames doc_str rdr_names_w_loc \begin{code} mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name change) -> Bool -- True <=> want unqualified import - -> Bool -- True <=> want qualified import - -> [AvailInfo] -- What's to be hidden (but only the unqualified - -- version is hidden) -> (Name -> Provenance) - -> Avails -- Whats imported and how + -> Avails -- Whats imported + -> Deprecations -> GlobalRdrEnv -mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails +mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs = gbl_env2 where -- Make the name environment. We're talking about a @@ -545,55 +691,47 @@ mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails -- In practice there only ever will be if it's the module -- being compiled. - -- Add the things that are available + -- Add qualified names for the things that are available + -- (Qualified names are always imported) gbl_env1 = foldl add_avail emptyRdrEnv avails - -- Delete things that are hidden - gbl_env2 = foldl del_avail gbl_env1 hides + -- Add unqualified names + gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1) + | otherwise = gbl_env1 + + add_unqual env (qual_name, elts) + = foldl add_one env elts + where + add_one env elt = addOneToGlobalRdrEnv env unqual_name elt + unqual_name = unqualifyRdrName qual_name + -- The qualified import should only have added one + -- binding for each qualified name! But if there's an error in + -- the module (multiple bindings for the same name) we may get + -- duplicates. So the simple thing is to do the fold. add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv add_avail env avail = foldl add_name env (availNames avail) - add_name env name - | qual_imp && unqual_imp = env3 - | unqual_imp = env2 - | qual_imp = env1 - | otherwise = env + add_name env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt where - env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) (name,prov) - env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) (name,prov) - env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov) occ = nameOccName name - prov = mk_provenance name - - del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names - where - rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail) - -mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv --- Used to construct a GlobalRdrEnv for an interface that we've --- read from a .hi file. We can't construct the original top-level --- environment because we don't have enough info, but we compromise --- by making an environment from its exports -mkIfaceGlobalRdrEnv m_avails - = foldl add emptyRdrEnv m_avails - where - add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails) + elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) \end{code} \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [(Name,Provenance)] -- Old - -> [(Name,Provenance)] -- New - -> [(Name,Provenance)] +combine_globals :: [GlobalRdrElt] -- Old + -> [GlobalRdrElt] -- New + -> [GlobalRdrElt] combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where @@ -603,11 +741,11 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm + (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm - is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool - is_duplicate (n1,LocalDef) (n2,LocalDef) = False - is_duplicate (n1,_) (n2,_) = n1 == n2 + is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool + is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False + is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -630,13 +768,19 @@ in error messages. \begin{code} unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. unQualInScope env = (`elemNameSet` unqual_names) where unqual_names :: NameSet unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name - add _ _ unquals = unquals + add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals \end{code} @@ -657,7 +801,6 @@ plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) addAvail :: AvailEnv -> AvailInfo -> AvailEnv addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail -emptyAvailEnv = emptyNameEnv unitAvailEnv :: AvailInfo -> AvailEnv unitAvailEnv a = unitNameEnv (availName a) a @@ -755,6 +898,21 @@ sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) n1 `lt` n2 = nameOccName n1 < nameOccName n2 \end{code} +\begin{code} +pruneAvails :: (Name -> Bool) -- Keep if this is True + -> [AvailInfo] + -> [AvailInfo] +pruneAvails keep avails + = mapMaybe del avails + where + del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left! + del (Avail n) | keep n = Just (Avail n) + | otherwise = Nothing + del (AvailTC n ns) | null ns' = Nothing + | otherwise = Just (AvailTC n ns') + where + ns' = filter keep ns +\end{code} %************************************************************************ %* * @@ -781,9 +939,7 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> \begin{code} warnUnusedModules :: [ModuleName] -> RnM d () warnUnusedModules mods - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then mapRn_ (addWarnRn . unused_mod) mods - else returnRn () + = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", @@ -792,19 +948,14 @@ warnUnusedModules mods warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then warnUnusedBinds names else returnRn () + = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () warnUnusedLocalBinds names - = doptRn Opt_WarnUnusedBinds `thenRn` \ warn -> - if warn then warnUnusedBinds [(n,LocalDef) | n<-names] - else returnRn () + = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) warnUnusedMatches names - = doptRn Opt_WarnUnusedMatches `thenRn` \ warn -> - if warn then warnUnusedGroup [(n,LocalDef) | n<-names] - else returnRn () + = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) ------------------------- @@ -851,12 +1002,7 @@ addNameClashErrRn rdr_name (np1:nps) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov - -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]) + mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), @@ -870,14 +1016,20 @@ unknownNameErr name qualNameErr descriptor (name,loc) = pushSrcLocRn loc $ - addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), - quotes (ppr name), - ptext SLIT("in"), + addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) = pushSrcLocRn loc $ addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ - (ptext SLIT("in") <+> descriptor)) + descriptor) + +warnDeprec :: Name -> DeprecTxt -> RnM d () +warnDeprec name txt + = ifOptRn Opt_WarnDeprecations $ + addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> + quotes (ppr name) <+> text "is deprecated:", + nest 4 (ppr txt) ]) \end{code} +