X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=affbcc9e91ce76658356756837356a5b40602ae6;hb=2427987977bc68edacd7b552909bfdb264884b85;hp=4fc2a3ab98cca5014de26f552ee1606e3b2c3fea;hpb=bac531aaf56c7558eda70531e9565f753d21f848;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 4fc2a3a..affbcc9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,35 +8,54 @@ module RnEnv where -- Export everything #include "HsVersions.h" +import {-# SOURCE #-} RnHiFiles + import HsSyn -import RdrHsSyn ( RdrNameIE ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, - mkRdrUnqual, qualifyRdrName, lookupRdrEnv +import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, + mkRdrUnqual, mkRdrQual, + lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, + unqualifyRdrName ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo ) + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + ModIface(..), + Deprecations(..), lookupDeprec, + extendLocalRdrEnv + ) import RnMonad -import Name ( Name, NamedThing(..), - getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, - mkIPName, nameOccName, nameModule, - extendNameEnv_C, plusNameEnv_C, nameEnvElts, +import Name ( Name, + getSrcLoc, nameIsLocalOrFrom, + mkLocalName, mkGlobalName, nameModule, + mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) +import NameEnv import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) -import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS ) +import Module ( ModuleName, moduleName, mkVanillaModule, + 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 Unique ( Unique ) 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 CmdLineOpts import FastString ( FastString ) \end{code} @@ -49,14 +68,29 @@ import FastString ( FastString ) \begin{code} newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name + -- newTopBinder puts into the cache the binder with the + -- module information set correctly. When the decl is later renamed, + -- the binding site will thereby get the correct module. + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + newTopBinder mod rdr_name loc = -- First check the cache - traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_` - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + -- 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 "In its declaration") (rdr_name,loc) + else + returnRn () + ) `thenRn_` + + getNameSupplyRn `thenRn` \ name_supply -> let occ = rdrNameOcc rdr_name key = (moduleName mod, occ) + cache = nsNames name_supply in case lookupFM cache key of @@ -71,8 +105,8 @@ newTopBinder mod rdr_name loc new_name = setNameModuleAndLoc name mod loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us, new_cache, ipcache) `thenRn_` - traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` + setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` +-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! @@ -80,13 +114,13 @@ newTopBinder mod rdr_name loc -- Even for locally-defined names we use implicitImportProvenance; -- updateProvenances will set it to rights Nothing -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 new_name = mkGlobalName uniq mod occ loc new_cache = addToFM cache key new_name in - setNameSupplyRn (us', new_cache, ipcache) `thenRn_` - traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` + setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` +-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -109,36 +143,43 @@ newGlobalName :: ModuleName -> OccName -> RnM d Name -- (but since it affects DLL-ery it does matter that we get it right -- in the end). newGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + = getNameSupplyRn `thenRn` \ name_supply -> let key = (mod_name, occ) + cache = nsNames name_supply in case lookupFM cache key of - Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` + Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` returnRn name - Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_` - traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` + Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` + -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` returnRn name where - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 mod = mkVanillaModule mod_name name = mkGlobalName uniq mod occ noSrcLoc new_cache = addToFM cache key name -newIPName rdr_name - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> +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 (us', cache, new_ipcache) `thenRn_` - returnRn name + Just name_ip -> returnRn name_ip + Nothing -> setNameSupplyRn new_ns `thenRn_` + returnRn name_ip where - (us', us1) = splitUniqSupply us + (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} %********************************************************* @@ -157,28 +198,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 -> - case mode of - InterfaceMode -> -- Look in the global name cache - lookupOrigName rdr_name - - SourceMode -> -- 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 -> - case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of - Just ((name,_):rest) -> ASSERT( null rest ) - returnRn name - Nothing -> -- Almost always this case is a compiler bug. - -- But consider a type signature that doesn't have - -- a corresponding binder: - -- module M where { f :: Int->Int } - -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons) - -- and we don't want to panic. So we report an out-of-scope error - failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + if isInterfaceMode mode + then lookupIfaceName 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? @@ -193,6 +244,31 @@ 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 + -- class not in scope; don't fail as later checks will catch this, + -- but just return (bogus) name. Icky. + 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 @@ -205,36 +281,85 @@ lookupOccRn rdr_name -- environment. It's used only for -- record field names -- class op names in class and instance decls -lookupGlobalOccRn rdr_name - = getModeRn `thenRn` \ mode -> - case mode of { - -- When processing interface files, the global env - -- is always empty, so go straight to the name cache - InterfaceMode -> lookupOrigName rdr_name ; - SourceMode -> +lookupGlobalOccRn rdr_name + = getModeRn `thenRn` \ mode -> + if (isInterfaceMode mode) + then lookupIfaceName rdr_name + else getGlobalNameEnv `thenRn` \ global_env -> - case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn name - Just stuff@((name,_):_) - -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> -- Not found when processing source code; so fail - failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - } - -lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name) - -- Checks that there is exactly one -lookupGlobalRn global_env rdr_name + case mode of + SourceMode -> lookupSrcName global_env rdr_name + + CmdLineMode + | not (isQual rdr_name) -> + lookupSrcName global_env rdr_name + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + -- + -- First look up the name in the normal environment. If + -- it isn't there, we manufacture a new occurrence of an + -- original name. + | otherwise -> + case lookupRdrEnv global_env rdr_name of + Just _ -> lookupSrcName global_env rdr_name + Nothing -> lookupQualifiedName rdr_name + +-- a qualified name on the command line can refer to any module at all: we +-- try to load the interface if we don't already have it. +lookupQualifiedName :: RdrName -> RnM d Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + case [ name | (_,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) returnRn n + _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) + +lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name +-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad +lookupSrcName global_env rdr_name + | isOrig rdr_name -- Can occur in source code too + = lookupOrigName rdr_name + + | otherwise = case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn (Just name) - Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn (Just name) - Nothing -> returnRn Nothing + 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 + = ASSERT( isOrig rdr_name ) + newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +lookupIfaceUnqual :: RdrName -> RnM d Name +lookupIfaceUnqual rdr_name + = ASSERT( isUnqual rdr_name ) + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + getModuleRn `thenRn ` \ mod -> + newGlobalName (moduleName mod) (rdrNameOcc rdr_name) + +lookupIfaceName :: RdrName -> RnM d Name +lookupIfaceName rdr_name + | isUnqual rdr_name = lookupIfaceUnqual rdr_name + | otherwise = lookupOrigName rdr_name \end{code} -% @lookupOrigName@ takes an RdrName representing an {\em original} name, and adds it to the occurrence pool so that it'll be loaded @@ -250,34 +375,17 @@ calls it at all I think). \fbox{{\em 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 -whether there are any instance decls in this module are ``special''. -The name cache should have the correct provenance, though. - \begin{code} -lookupOrigName :: RdrName -> RnM d Name -lookupOrigName rdr_name - | isQual rdr_name - = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - - | otherwise - = -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - getModuleRn `thenRn ` \ mod -> - newGlobalName (moduleName mod) (rdrNameOcc rdr_name) - lookupOrigNames :: [RdrName] -> RnM d NameSet lookupOrigNames rdr_names = mapRn lookupOrigName rdr_names `thenRn` \ names -> returnRn (mkNameSet names) \end{code} -lookupSysBinder is used for the "system binders" of a type, class, or instance decl. -It ensures that the module is set correctly in the name cache, and sets the provenance -on the returned name too. The returned name will end up actually in the type, class, -or instance. +lookupSysBinder is used for the "system binders" of a type, class, or +instance decl. It ensures that the module is set correctly in the +name cache, and sets the provenance on the returned name too. The +returned name will end up actually in the type, class, or instance. \begin{code} lookupSysBinder rdr_name @@ -288,6 +396,92 @@ lookupSysBinder rdr_name \end{code} +%********************************************************* +%* * +\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_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, + 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} + %********************************************************* %* * @@ -296,20 +490,18 @@ lookupSysBinder rdr_name %********************************************************* \begin{code} -newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name) - -> [(RdrName,SrcLoc)] +newLocalsRn :: [(RdrName,SrcLoc)] -> RnMS [Name] -newLocalsRn mk_name rdr_names_w_loc - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> +newLocalsRn rdr_names_w_loc + = getNameSupplyRn `thenRn` \ name_supply -> let - n = length rdr_names_w_loc - (us', us1) = splitUniqSupply us - uniqs = uniqsFromSupply n us1 - names = [ mk_name uniq (rdrNameOcc rdr_name) loc + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniqs = uniqsFromSupply us1 + names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (us', cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` returnRn names @@ -319,39 +511,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 - (case mode of - SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc - other -> returnRn () - ) `thenRn_` - let - mk_name = case mode of - SourceMode -> mkLocalName - InterfaceMode -> mkImportedLocalName - -- Keep track of whether the name originally came from - -- an interface file. + check_shadow (rdr_name,loc) + | rdr_name `elemRdrEnv` local_env + || rdr_name `elemRdrEnv` global_env + = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + | otherwise + = returnRn () in - newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names -> + + (case mode of + 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) @@ -362,13 +549,13 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a bindCoreLocalRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + getNameSupplyRn `thenRn` \ name_supply -> let - (us', us1) = splitUniqSupply us + (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc + name = mkLocalName uniq (rdrNameOcc rdr_name) loc in - setNameSupplyRn (us', cache, ipcache) `thenRn_` + setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` let new_name_env = extendRdrEnv name_env rdr_name name in @@ -381,10 +568,14 @@ 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 $ + enclosed_scope `thenRn` \ (thing, fvs) -> + returnRn (thing, delListFromNameSet fvs names) + ------------------------------------- bindLocalRn doc rdr_name enclosed_scope @@ -407,12 +598,8 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a -bindUVarRn = bindCoreLocalRn - -------------------------------------- extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) - -- This tiresome function is used only in rnDecl on InstDecl + -- This tiresome function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs tyvars) @@ -436,32 +623,29 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope 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) - -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) @@ -476,7 +660,7 @@ checkDupOrQualNames doc_str rdr_names_w_loc mapRn_ (qualNameErr doc_str) quals `thenRn_` checkDupNames doc_str rdr_names_w_loc where - quals = filter (isQual.fst) rdr_names_w_loc + quals = filter (isQual . fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group @@ -493,18 +677,86 @@ 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 + -> (Name -> Provenance) + -> Avails -- Whats imported + -> Avails -- What's to be hidden + -- I.e. import (imports - hides) + -> Deprecations + -> GlobalRdrEnv + +mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails hides deprecs + = gbl_env3 + where + -- Make the name environment. We're talking about a + -- single module here, so there must be no name clashes. + -- In practice there only ever will be if it's the module + -- being compiled. + + -- Add qualified names for the things that are available + -- (Qualified names are always imported) + gbl_env1 = foldl add_avail emptyRdrEnv avails + + -- Delete (qualified names of) things that are hidden + gbl_env2 = foldl del_avail gbl_env1 hides + + -- Add unqualified names + gbl_env3 | unqual_imp = foldl add_unqual gbl_env2 (rdrEnvToList gbl_env2) + | otherwise = gbl_env2 + + 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. + + del_avail env avail + = foldl delOneFromGlobalRdrEnv env rdr_names + where + rdr_names = map (mkRdrQual this_mod . nameOccName) + (availNames avail) + + + add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv + add_avail env avail = foldl add_name env (availNames avail) + + add_name env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + where + occ = nameOccName name + elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) + +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 + (\n -> LocalDef) avails [] NoDeprecs) + -- The NoDeprecs is a bit of a hack I suppose +\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 @@ -514,11 +766,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, @@ -541,12 +793,15 @@ in error messages. \begin{code} unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') unQualInScope env - = lookup + = (`elemNameSet` unqual_names) where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [(name',_)] -> name == name' - other -> False + unqual_names :: NameSet + unqual_names = foldRdrEnv add emptyNameSet env + add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals \end{code} @@ -561,13 +816,12 @@ plusAvail (Avail n1) (Avail n2) = Avail n1 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) -- Added SOF 4/97 #ifdef DEBUG -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2]) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) #endif 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 @@ -591,18 +845,6 @@ availNames (Avail n) = [n] availNames (AvailTC n ns) = ns ------------------------------------- -addSysAvails :: AvailInfo -> [Name] -> AvailInfo -addSysAvails avail [] = avail -addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) - -------------------------------------- -rdrAvailInfo :: AvailInfo -> RdrAvailInfo --- Used when building the avails we are going to put in an interface file --- We sort the components to reduce needless wobbling of interfaces -rdrAvailInfo (Avail n) = Avail (nameOccName n) -rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns)) - -------------------------------------- filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; @@ -639,36 +881,42 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail filterAvail ie avail = Nothing ------------------------------------- -groupAvails :: Avails -> [(ModuleName, Avails)] +groupAvails :: Module -> Avails -> [(ModuleName, Avails)] -- Group by module and sort by occurrence -- This keeps the list in canonical order -groupAvails avails +groupAvails this_mod avails = [ (mkSysModuleNameFS fs, sortLt lt avails) | (fs,avails) <- fmToList groupFM ] where groupFM :: FiniteMap FastString Avails - -- Deliberatey use the FastString so we + -- Deliberately use the FastString so we -- get a canonical ordering groupFM = foldl add emptyFM avails - add env avail = addToFM_C combine env mod_fs [avail] + add env avail = addToFM_C combine env mod_fs [avail'] where - mod_fs = moduleNameFS (moduleName (nameModule (availName avail))) - combine old _ = avail:old + mod_fs = moduleNameFS (moduleName avail_mod) + avail_mod = case nameModule_maybe (availName avail) of + Just m -> m + Nothing -> this_mod + combine old _ = avail':old + avail' = sortAvail avail a1 `lt` a2 = occ1 < occ2 where occ1 = nameOccName (availName a1) occ2 = nameOccName (availName a2) - -------------------------------------- -pprAvail :: AvailInfo -> SDoc -pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of - [] -> empty - ns' -> parens (hsep (punctuate comma (map ppr ns'))) -pprAvail (Avail n) = ppr n +sortAvail :: AvailInfo -> AvailInfo +-- Sort the sub-names into canonical order. +-- The canonical order has the "main name" at the beginning +-- (if it's there at all) +sortAvail (Avail n) = Avail n +sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) + | otherwise = AvailTC n ( sortLt lt ns) + where + n1 `lt` n2 = nameOccName n1 < nameOccName n2 \end{code} @@ -697,9 +945,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", @@ -708,19 +954,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]) ------------------------- @@ -750,7 +991,7 @@ warnUnusedGroup names = case prov1 of LocalDef -> (True, getSrcLoc name1, text "Defined but not used") - NonLocalDef (UserImport mod loc _) _ + NonLocalDef (UserImport mod loc _) -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") reportable (name,_) = case occNameUserString (nameOccName name) of @@ -767,12 +1008,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"), @@ -786,14 +1022,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} +