X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=d12aab932503c50329f6da2093344a9921d4727b;hb=49c84dec1a5612852fb0f484e7dd3be0c99636f4;hp=34a254e0de449079cd4e1d8581d4ff09106a12fc;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 34a254e..d12aab9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,40 +10,41 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles -import HscTypes ( ModIface(..) ) +import FlattenInfo ( namesNeededForFlattening ) import HsSyn -import RnHsSyn ( RenamedHsDecl ) -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, GlobalRdrElt(..), AvailEnv, AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), GhciMode(..), Deprecations(..), lookupDeprec, extendLocalRdrEnv ) import RnMonad -import Name ( Name, - getSrcLoc, +import Name ( Name, + getSrcLoc, nameIsLocalOrFrom, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, mkNameEnv + 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(..) ) -import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap, +import PrelNames ( mkUnboundName, derivingOccurrences, - mAIN_Name, pREL_MAIN_Name, - ioTyConName, integerTyConName, doubleTyConName, intTyConName, + mAIN_Name, main_RDR_Unqual, + runMainName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, - hasKey, fractionalClassKey, numClassKey, bindIOName, returnIOName, failIOName ) import TysWiredIn ( unitTyCon ) -- A little odd @@ -53,9 +54,10 @@ import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) +import BasicTypes ( mapIPName ) import List ( nub ) import UniqFM ( lookupWithDefaultUFM ) -import Maybes ( orElse ) +import Maybe ( mapMaybe ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -81,7 +83,7 @@ newTopBinder mod rdr_name loc -- 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_` @@ -162,21 +164,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} %********************************************************* @@ -195,16 +200,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? @@ -219,6 +246,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 @@ -267,7 +321,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, @@ -352,48 +406,26 @@ lookupSysBinder rdr_name %* * %********************************************************* -@addImplicitFVs@ forces the renamer to slurp in some things which aren't +@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} -addImplicitFVs :: GlobalRdrEnv - -> Maybe (ModuleName, [RenamedHsDecl]) -- Nothing when compling an expression - -> FreeVars -- Free in the source - -> RnMG (FreeVars, SyntaxMap) -- Augmented source free vars - -addImplicitFVs gbl_env maybe_mod source_fvs - = -- Find out what re-bindable names to use for desugaring - rnSyntaxNames gbl_env source_fvs `thenRn` \ (source_fvs1, sugar_map) -> - - -- Find implicit FVs thade - extra_implicits maybe_mod `thenRn` \ extra_fvs -> - - let - implicit_fvs = ubiquitousNames `plusFV` extra_fvs - slurp_fvs = implicit_fvs `plusFV` source_fvs1 - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - in - returnRn (slurp_fvs, sugar_map) - - where - extra_implicits Nothing -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName]) +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 - extra_implicits (Just (mod_name, decls)) -- Compiling a module - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` implicit_main) - where - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyConName - | otherwise = emptyFVs - +getImplicitModuleFVs decls -- Compiling a module + = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> + returnRn (deriving_names `plusFV` ubiquitousNames) + where + -- 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, - cls <- deriv_classes, + HsClassP cls [] <- deriv_classes, occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] -- ubiquitous_names are loaded regardless, because @@ -408,55 +440,77 @@ ubiquitousNames -- 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} + `plusFV` + namesNeededForFlattening + -- this will be empty unless flattening is activated + +checkMain ghci_mode mod_name gbl_env + -- LOOKUP main IF WE'RE IN MODULE Main + -- The main point of this is to drag in the declaration for 'main', + -- its in another module, and for the Prelude function 'runMain', + -- so that the type checker will find them + -- + -- We have to return the main_name separately, because it's a + -- bona fide 'use', and should be recorded as such, but the others + -- aren't + | mod_name /= mAIN_Name + = returnRn (Nothing, emptyFVs, emptyFVs) + + | not (main_RDR_Unqual `elemRdrEnv` gbl_env) + = complain_no_main `thenRn_` + returnRn (Nothing, emptyFVs, emptyFVs) -\begin{code} -implicitGates :: Name -> FreeVars --- If we load class Num, add Integer to the gates --- This takes account of the fact that Integer might be needed for --- defaulting, but we don't want to load Integer (and all its baggage) --- if there's no numeric stuff needed. --- Similarly for class Fractional and Double --- --- NB: If we load (say) Floating, we'll end up loading Fractional too, --- since Fractional is a superclass of Floating -implicitGates cls | cls `hasKey` numClassKey = unitFV integerTyConName - | cls `hasKey` fractionalClassKey = unitFV doubleTyConName - | otherwise = emptyFVs + | otherwise + = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> + returnRn (Just main_name, unitFV main_name, unitFV runMainName) + + where + complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg + | otherwise = addErrRn noMainMsg + -- In interactive mode, only warn about the absence of main \end{code} -\begin{code} -rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap) --- Look up the re-bindable syntactic sugar names --- Any errors arising from these lookups may surprise the --- programmer, since they aren't explicitly mentioned, and --- the src line will be unhelpful (ToDo) +%************************************************************************ +%* * +\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. -rnSyntaxNames gbl_env source_fvs +\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 (source_fvs, vanillaSyntaxMap) + returnRn std_name -- Normal case else - - -- There's a -fno-implicit-prelude flag, - -- so build the re-mapping function let - reqd_syntax_list = filter is_reqd syntaxList - is_reqd (n,_) = n `elemNameSet` source_fvs - lookup (n,rn) = lookupSrcName gbl_env rn `thenRn` \ rn' -> - returnRn (n,rn') + rdr_name = mkRdrUnqual (nameOccName std_name) + -- Get the similarly named thing from the local environment in - mapRn lookup reqd_syntax_list `thenRn` \ rn_syntax_list -> - let - -- Delete the proxies and add the actuals - proxies = map fst rn_syntax_list - actuals = map snd rn_syntax_list - new_source_fvs = (proxies `delFVs` source_fvs) `plusFV` mkFVs actuals - - syntax_env = mkNameEnv rn_syntax_list - syntax_map n = lookupNameEnv syntax_env n `orElse` n - in - returnRn (new_source_fvs, syntax_map) + lookupOccRn rdr_name \end{code} @@ -472,9 +526,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 ] @@ -489,32 +542,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) @@ -584,47 +639,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) @@ -658,16 +702,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 deprecs +mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs = gbl_env2 where -- Make the name environment. We're talking about a @@ -675,42 +715,32 @@ mkGlobalRdrEnv this_mod unqual_imp qual_imp hides -- 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) elt - env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) elt - env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) elt occ = nameOccName name elt = GRE name (mk_provenance name) (lookupDeprec deprecs 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 NoDeprecs) - -- The NoDeprecs is a bit of a hack I suppose \end{code} \begin{code} @@ -762,6 +792,12 @@ 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 @@ -789,7 +825,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 @@ -887,6 +922,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} %************************************************************************ %* * @@ -913,9 +963,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", @@ -924,19 +972,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]) ------------------------- @@ -990,6 +1033,8 @@ shadowedNameWarn shadow quotes (ppr shadow), ptext SLIT("shadows an existing binding")] +noMainMsg = ptext SLIT("No 'main' defined in module Main") + unknownNameErr name = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where @@ -997,22 +1042,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 - = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> - if not warn_drs then returnRn () else + = ifOptRn Opt_WarnDeprecations $ addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) \end{code} +