X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=fa8e8e380d58774c44994e3c589f15ece13ba698;hb=8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2;hp=6d212cc7ab5358e2b4f9160698b11df3d80e55fb;hpb=9adbdb312507dcc7d5777e36376535918549103b;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 6d212cc..fa8e8e3 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,38 +8,54 @@ module RnEnv where -- Export everything #include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, - opt_WarnUnusedBinds, opt_WarnUnusedImports ) +import {-# SOURCE #-} RnHiFiles( loadInterface ) + +import FlattenInfo ( namesNeededForFlattening ) import HsSyn -import RdrHsSyn ( RdrNameIE ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, - mkRdrUnqual, qualifyRdrName +import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) +import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, + mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, + lookupRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, addListToRdrEnv, emptyRdrEnv, + isExact_maybe, unqualifyRdrName ) -import HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName ) -import HscTypes ( pprNameProvenance ) -import RnMonad -import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), - ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, hasBetterProv, isLocallyDefined, - nameOccName, setNameModule, nameModule, - extendNameEnv_C, plusNameEnv_C, nameEnvElts +import HsTypes ( hsTyVarName, replaceTyVarName ) +import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), + GenAvailInfo(..), AvailInfo, Avails, + ModIface(..), NameCache(..), + Deprecations(..), lookupDeprec, isLocalGRE, + extendLocalRdrEnv, availName, availNames, + lookupFixity ) +import TcRnMonad +import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName, + mkInternalName, mkExternalName, mkIPName, + nameOccName, setNameModuleAndLoc, nameModule ) import NameSet -import OccName ( OccName, occNameUserString, occNameFlavour ) -import Module ( ModuleName, moduleName, mkVanillaModule, pprModuleName ) +import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour ) +import Module ( Module, ModuleName, moduleName, mkVanillaModule ) +import PrelNames ( mkUnboundName, intTyConName, + boolTyConName, funTyConName, + unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + eqStringName, printName, + bindIOName, returnIOName, failIOName, thenIOName + ) +#ifdef GHCI +import DsMeta ( templateHaskellNames, qTyConName ) +#endif +import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap -import Unique ( Unique ) import UniqSupply -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import Util ( thenCmp, sortLt ) +import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) +import CmdLineOpts +import FastString ( FastString ) \end{code} - - %********************************************************* %* * \subsection{Making new names} @@ -47,17 +63,25 @@ import List ( nub ) %********************************************************* \begin{code} -implicitImportProvenance = NonLocalDef ImplicitImport False +newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m 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 :: Module -> RdrName -> SrcLoc -> RnM d Name newTopBinder mod rdr_name loc - = -- First check the cache - traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_` + | Just name <- isExact_maybe rdr_name + = returnM name - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> + | otherwise + = -- First check the cache + getNameCache `thenM` \ name_supply -> let occ = rdrNameOcc rdr_name key = (moduleName mod, occ) + cache = nsNames name_supply in case lookupFM cache key of @@ -68,30 +92,25 @@ newTopBinder mod rdr_name loc -- b) its defining SrcLoc -- So we update this info - Just name -> let - 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_` - returnRn new_name + Just name + | isWiredInName name -> returnM name + -- Don't mess with wired-in names. Apart from anything + -- else, their wired-in-ness is in the SrcLoca + | otherwise + -> let + new_name = setNameModuleAndLoc name mod loc + new_cache = addToFM cache key new_name + in + setNameCache (name_supply {nsNames = new_cache}) `thenM_` + returnM new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache -- Even for locally-defined names we use implicitImportProvenance; -- updateProvenances will set it to rights - Nothing -> let - (us', us1) = splitUniqSupply us - 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_` - returnRn new_name - - -newGlobalName :: ModuleName -> OccName -> RnM d Name + Nothing -> addNewName name_supply key mod occ loc + +newGlobalName :: ModuleName -> OccName -> TcRn m Name -- Used for *occurrences*. We make a place-holder Name, really just -- to agree on its unique, which gets overwritten when we read in -- the binding occurence later (newTopBinder) @@ -110,36 +129,70 @@ 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) -> + = getNameCache `thenM` \ 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_` - returnRn name + Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenM_` + returnM name + + Nothing -> -- traceRn (text "newGlobalName: new" <+> ppr name) `thenM_` + addNewName name_supply key (mkVanillaModule mod_name) occ noSrcLoc + +-- Look up a "system name" in the name cache. +-- This is done by the type checker... +-- For *source* declarations, this will put the thing into the name cache +-- For *interface* declarations, RnHiFiles.getSysBinders will already have +-- put it into the cache. +lookupSysName :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRn m Name -- System name +lookupSysName base_name mk_sys_occ + = getNameCache `thenM` \ name_supply -> + let + mod = nameModule base_name + occ = mk_sys_occ (nameOccName base_name) + key = (moduleName mod, occ) + in + case lookupFM (nsNames name_supply) key of + Just name -> returnM name + Nothing -> addNewName name_supply key mod occ noSrcLoc - Nothing -> setNameSupplyRn (us', new_cache, ipcache) `thenRn_` - traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply us - 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 + = getNameCache `thenM` \ 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 -> returnM name_ip + Nothing -> setNameCache new_ns `thenM_` + returnM 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 + +addNewName :: NameCache -> (ModuleName,OccName) + -> Module -> OccName -> SrcLoc -> TcRn m Name +-- Internal function: extend the name cache, dump it back into +-- the monad, and return the new name +-- (internal, hence the rather redundant interface) +addNewName name_supply key mod occ loc + = setNameCache new_name_supply `thenM_` + returnM name + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name = mkExternalName uniq mod occ loc + new_cache = addToFM (nsNames name_supply) key name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} \end{code} %********************************************************* @@ -152,34 +205,79 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name - = 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) +-- 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. + + -- There should never be a qualified name in a binding position + -- The parser could check this, but doesn't (yet) + | isQual rdr_name + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise + = ASSERT( not (isOrig rdr_name) ) + -- Original names are used only for occurrences, + -- not binding sites + + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> + getSrcLocM `thenM` \ loc -> + newTopBinder mod rdr_name loc + + other -> lookupTopSrcBndr rdr_name + +lookupTopSrcBndr :: RdrName -> TcRn m Name +lookupTopSrcBndr rdr_name + = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> + case maybe_name of + Just name -> returnM name + Nothing -> unboundName rdr_name + + +lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) +-- Look up a source-code binder + +-- Ignores imported names; for example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course + +lookupTopSrcBndr_maybe rdr_name + | Just name <- isExact_maybe rdr_name + -- This is here just to catch the PrelBase defn of (say) [] and similar + -- The parser reads the special syntax and returns an Exact 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 + -- + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + = getModule `thenM` \ mod -> + checkErr (moduleName mod == moduleName (nameModule name)) + (badOrigBinding rdr_name) `thenM_` + returnM (Just name) + + | otherwise + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Nothing -> returnM Nothing + Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of + [] -> returnM Nothing + (n:ns) -> returnM (Just n) + -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -191,94 +289,362 @@ lookupTopBndrRn rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn -lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn :: RdrName -> RnM Name lookupSigOccRn = lookupBndrRn +-- lookupInstDeclBndr is used for the binders in an +-- instance declaration. Here we use the class name to +-- disambiguate. + +lookupInstDeclBndr :: Name -> RdrName -> RnM Name + -- We use the selector name as the binder +lookupInstDeclBndr cls_name rdr_name + | isUnqual rdr_name + = -- Find all the things the class op name maps to + -- and pick the one with the right parent name + getGblEnv `thenM` \ gbl_env -> + let + avail_env = imp_env (tcg_imports gbl_env) + in + case lookupAvailEnv avail_env cls_name of + Nothing -> + -- If the class itself isn't in scope, then cls_name will + -- be unboundName, and there'll already be an error for + -- that in the error list. Example: + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + returnM (mkUnboundName rdr_name) + + Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of + (n:ns)-> ASSERT( null ns ) returnM n + [] -> unboundName rdr_name + + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) + + | isQual rdr_name -- Should never have a qualified name in a binding position + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method, and avail_env + -- isn't available + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + lookupOrigName rdr_name + + where + occ = rdrNameOcc rdr_name + +lookupSysBndr :: RdrName -> RnM Name +-- Used for the 'system binders' in a data type or class declaration +-- Do *not* look up in the RdrEnv; these system binders are never in scope +-- Instead, get the module from the monad... but remember that +-- where the module is depends on whether we are renaming source or +-- interface file stuff +lookupSysBndr rdr_name + = getSrcLocM `thenM` \ loc -> + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> newTopBinder mod rdr_name loc + other -> getModule `thenM` \ mod -> + newTopBinder mod rdr_name loc + -- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnMS Name +lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- 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 `thenM` \ mode -> + case mode of + InterfaceMode mod -> lookupIfaceName mod rdr_name + SourceMode -> lookupSrcName rdr_name + + CmdLineMode + | not (isQual rdr_name) -> + lookupSrcName 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 -> + lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Just name -> returnM 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 -> TcRn m Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface -> + case [ name | (_,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) returnM n + _ -> unboundName rdr_name + +lookupSrcName :: RdrName -> TcRn m Name +lookupSrcName rdr_name + = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Nothing -> unboundName rdr_name + Just name -> returnM name + +lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) +lookupSrcName_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- Can occur in source code too + = returnM (Just name) + + | isOrig rdr_name -- An original name + = newGlobalName (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) `thenM` \ name -> + returnM (Just name) - getGlobalNameEnv `thenRn` \ global_env -> + | otherwise + = lookupGRE rdr_name `thenM` \ mb_gre -> + case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) + +lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) +lookupGRE rdr_name + = getGlobalRdrEnv `thenM` \ global_env -> case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn name - Just stuff@(_:_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> -- Not found when processing source code; so fail - failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - } -\end{code} -% + Just [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> warnDeprec gre `thenM_` + returnM (Just gre) + Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` + returnM (Just gre) + Nothing -> return Nothing + +lookupIfaceName :: Module -> RdrName -> TcRn m Name + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. +lookupIfaceName mod rdr_name + | isUnqual rdr_name = newGlobalName (moduleName mod) (rdrNameOcc rdr_name) + | otherwise = lookupOrigName rdr_name -@lookupOrigName@ takes an RdrName representing an {\em original} -name, and adds it to the occurrence pool so that it'll be loaded -later. This is used when language constructs (such as monad -comprehensions, overloaded literals, or deriving clauses) require some -stuff to be loaded that isn't explicitly mentioned in the code. +lookupOrigName :: RdrName -> TcRn m Name + -- Just for original or exact names +lookupOrigName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code, which we + -- rename in InterfaceMode + = returnM n -This doesn't apply in interface mode, where everything is explicit, -but we don't check for this case: it does no harm to record an -``extra'' occurrence and @lookupOrigNames@ isn't used much in -interface mode (it's only the @Nothing@ clause of @rnDerivs@ that -calls it at all I think). + | otherwise -- Usually Orig, but can be a Qual when + -- we are reading a .hi-boot file + = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - \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. +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName +\end{code} \begin{code} -lookupOrigName :: RdrName -> RnM d Name -lookupOrigName rdr_name - | isQual rdr_name - = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) +unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` + returnM (mkUnboundName rdr_name) +\end{code} - | 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) +%********************************************************* +%* * + Fixities +%* * +%********************************************************* -lookupOrigNames :: [RdrName] -> RnM d NameSet -lookupOrigNames rdr_names - = mapRn lookupOrigName rdr_names `thenRn` \ names -> - returnRn (mkNameSet names) +\begin{code} +-------------------------------- +bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> + extendFixityEnv new_bit thing_inside + where + rn_sig (FixitySig v fix src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (new_v, FixitySig new_v fix src_loc) \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. +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the HIT or PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with RnNames.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment \begin{code} -lookupSysBinder rdr_name - = ASSERT( isUnqual rdr_name ) - getModuleRn `thenRn` \ mod -> - getSrcLocRn `thenRn` \ loc -> - newTopBinder mod rdr_name loc +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name + = getModule `thenM` \ this_mod -> + if nameIsLocalOrFrom this_mod name + then -- It's defined in this module + getFixityEnv `thenM` \ local_fix_env -> + returnM (lookupFixity local_fix_env name) + + else -- It's imported + -- For imported names, we have to get their fixities by doing a + -- loadHomeInterface, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + loadInterface doc name_mod ImportBySystem `thenM` \ iface -> + returnM (lookupFixity (mi_fixities iface) name) + where + doc = ptext SLIT("Checking fixity for") <+> ppr name + name_mod = moduleName (nameModule 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} +implicitStmtFVs source_fvs -- Compiling a statement + = stmt_fvs `plusFV` implicitModuleFVs source_fvs + where + stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName] + -- These are all needed implicitly when compiling a statement + -- See TcModule.tc_stmts + +implicitModuleFVs source_fvs + = mkTemplateHaskellFVs source_fvs `plusFV` + namesNeededForFlattening `plusFV` + ubiquitousNames + + -- This is a bit of a hack. When we see the Template-Haskell construct + -- [| expr |] + -- we are going to need lots of the ``smart constructors'' defined in + -- the main Template Haskell data type module. Rather than treat them + -- all as free vars at every occurrence site, we just make the Q type + -- consructor a free var.... and then use that here to haul in the others +mkTemplateHaskellFVs source_fvs +#ifdef GHCI + -- Only if Template Haskell is enabled + | qTyConName `elemNameSet` source_fvs = templateHaskellNames +#endif + | otherwise = emptyFVs + +-- 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 + 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) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional + * NegApp + * NPlusKPatIn + * HsDo +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. + +We treat the orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. + +\begin{code} +lookupSyntaxName :: Name -- The standard name + -> RnM (Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName std_name + = getModeRn `thenM` \ mode -> + if isInterfaceMode mode then + returnM (std_name, unitFV std_name) + -- Happens for 'derived' code + -- where we don't want to rebind + else + + doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then + returnM (std_name, unitFV std_name) -- Normal case + + else + -- Get the similarly named thing from the local environment + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, mkFVs [usr_name, std_name]) +\end{code} + %********************************************************* %* * @@ -287,105 +653,95 @@ lookupSysBinder rdr_name %********************************************************* \begin{code} -newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name) - -> [(RdrName,SrcLoc)] - -> RnMS [Name] -newLocalsRn mk_name rdr_names_w_loc - = getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> +newLocalsRn :: [(RdrName,SrcLoc)] + -> RnM [Name] +newLocalsRn rdr_names_w_loc + = newUniqueSupply `thenM` \ us -> let - n = length rdr_names_w_loc - (us', us1) = splitUniqSupply us - uniqs = uniqsFromSupply n us1 - names = [ mk_name uniq (rdrNameOcc rdr_name) loc + uniqs = uniqsFromSupply us + names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (us', cache, ipcache) `thenRn_` - returnRn names + returnM names bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS a) - -> RnMS a + -> ([Name] -> RnM a) + -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ name_env -> + = getModeRn `thenM` \ mode -> + getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules - (case mode of - SourceMode | opt_WarnNameShadowing -> 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 + = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) + | otherwise + = returnM () in - newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names -> + + (case mode of + SourceMode -> ifOptM Opt_WarnNameShadowing $ + mappM_ check_shadow rdr_names_w_loc + other -> returnM () + ) `thenM_` + + newLocalsRn rdr_names_w_loc `thenM` \ 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) + setLocalRdrEnv 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) - -bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) +bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) -- * one at a time -- * no checks for shadowing -- * always imported -- * deal with free vars -bindCoreLocalFVRn rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> - let - (us', us1) = splitUniqSupply us - uniq = uniqFromSupply us1 - name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc - in - setNameSupplyRn (us', cache, ipcache) `thenRn_` +bindCoreLocalRn rdr_name enclosed_scope + = getSrcLocM `thenM` \ loc -> + getLocalRdrEnv `thenM` \ name_env -> + newUnique `thenM` \ uniq -> let + name = mkInternalName uniq (rdrNameOcc rdr_name) loc new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> - returnRn (result, delFromNameSet fvs name) + setLocalRdrEnv new_name_env (enclosed_scope name) -bindCoreLocalsFVRn [] thing_inside = thing_inside [] -bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> - bindCoreLocalsFVRn bs $ \ names' -> - thing_inside (name':names') +bindCoreLocalsRn [] thing_inside = thing_inside [] +bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> + bindCoreLocalsRn bs $ \ names' -> + thing_inside (name':names') bindLocalNames names enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (addListToRdrEnv name_env pairs) + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope - where - pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] + +bindLocalNamesFV names enclosed_scope + = bindLocalNames names $ + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) + ------------------------------------- bindLocalRn doc rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> ASSERT( null ns ) enclosed_scope n bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope @@ -394,84 +750,69 @@ bindLocalsRn doc rdr_names enclosed_scope -- except that it deals with free vars bindLocalsFVRn doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> - enclosed_scope names `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) - -------------------------------------- -bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) -bindUVarRn = bindLocalRn + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) - -- This tiresome function is used only in rnDecl on InstDecl +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- 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) + = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs tyvars) bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnMS a) - -> RnMS a + -> ([HsTyVarBndr Name] -> RnM a) + -> RnM 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 -> + = getSrcLocM `thenM` \ 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) - -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) - -bindNakedTyVarsFVRn :: SDoc -> [RdrName] - -> ([Name] -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) -bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + enclosed_scope (zipWith replaceTyVarName tyvar_names names) + +bindPatSigTyVars :: [RdrNameHsType] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) + -- Find the type variables in the pattern type + -- signatures that must be brought into scope + +bindPatSigTyVars tys enclosed_scope + = getLocalRdrEnv `thenM` \ name_env -> + getSrcLocM `thenM` \ 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) -> - returnRn (thing, delListFromNameSet fvs names) + bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM d () + -> TcRn m () -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn_ (qualNameErr doc_str) quals `thenRn_` + mappM_ (qualNameErr doc_str) quals `thenM_` 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 - mapRn_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc \end{code} @@ -484,18 +825,66 @@ 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 + -> Deprecations + -> GlobalRdrEnv + +mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs + = gbl_env2 + 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 + + -- 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 (availName avail)) env (availNames avail) + + add_name parent env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + where + occ = nameOccName name + elt = GRE {gre_name = name, + gre_parent = parent, + gre_prov = mk_provenance name, + gre_deprec = 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 @@ -505,11 +894,12 @@ 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 + g1 `beats` g2 = gre_name g1 == gre_name g2 && + gre_prov g1 `hasBetterProv` gre_prov g2 - is_duplicate :: Provenance -> (Name,Provenance) -> Bool - is_duplicate (n1,LocalDef _) (n2,LocalDef _) = False - is_duplicate _ _ = n1 == n2 + is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool + is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False + is_duplicate g1 g2 = gre_name g1 == gre_name g2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -525,116 +915,6 @@ defn of the same name; in this case the names will compare as equal, but will still have different provenances. -@unQualInScope@ 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} -unQualInScope :: GlobalRdrEnv -> Name -> Bool -unQualInScope env - = lookup - where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [(name',_)] -> name == name' - other -> False -\end{code} - - -%************************************************************************ -%* * -\subsection{Avails} -%* * -%************************************************************************ - -\begin{code} -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]) -#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 - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts = nameEnvElts - -addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names avail = addListToNameSet names (availNames avail) - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails - -availName :: GenAvailInfo name -> name -availName (Avail n) = n -availName (AvailTC n _) = n - -availNames :: GenAvailInfo name -> [name] -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; - -- Nothing if (any of the) wanted stuff isn't there - -filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) - | otherwise = Nothing - where - is_wanted name = nameOccName name `elem` wanted_occs - sub_names_ok = all (`elem` avail_occs) wanted_occs - avail_occs = map nameOccName ns - wanted_occs = map rdrNameOcc (want:wants) - -filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - Just (AvailTC n [n]) - -filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms - -filterAvail (IEVar _) avail@(Avail n) = Just avail -filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) - where - wanted n = nameOccName n == occ - occ = rdrNameOcc v - -- The second equation happens if we import a class op, thus - -- import A( op ) - -- where op is a class operation - -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail - -- We don't complain even if the IE says T(..), but - -- no constrs/class ops of T are available - -- Instead that's caught with a warning by the caller - -filterAvail ie avail = Nothing - -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 -\end{code} - - %************************************************************************ %* * \subsection{Free variable manipulation} @@ -642,31 +922,12 @@ pprAvail (Avail n) = ppr n %************************************************************************ \begin{code} -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars - -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionManyNameSets -plusFV = unionNameSets -mkFVs = mkNameSet - --- No point in adding implicitly imported names to the free-var set -addOneFV s n = addOneToNameSet s n -unitFV n = unitNameSet n - -- A useful utility -mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> +mapFvRn f xs = mappM f xs `thenM` \ stuff -> let (ys, fvs_s) = unzip stuff in - returnRn (ys, plusFVs fvs_s) + returnM (ys, plusFVs fvs_s) \end{code} @@ -677,68 +938,55 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [Module] -> RnM d () +warnUnusedModules :: [ModuleName] -> TcRn m () warnUnusedModules mods - | not opt_WarnUnusedImports = returnRn () - | otherwise = mapRn_ (addWarnRn . unused_mod . moduleName) mods + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where - unused_mod m = vcat [ptext SLIT("Module") <+> quotes (pprModuleName m) <+> + unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", - parens (ptext SLIT("except perhaps to re-export instances visible in") <+> - quotes (pprModuleName m))] - -warnUnusedImports :: [(Name,Provenance)] -> RnM d () -warnUnusedImports names - | not opt_WarnUnusedImports - = returnRn () -- Don't force names unless necessary - | otherwise - = warnUnusedBinds names + parens (ptext SLIT("except perhaps instances visible in") <+> + quotes (ppr m))] -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedLocalBinds ns - | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds [(n,LocalDef) | n<-ns] +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedGroup [(n,LocalDef) | n<-ns] - | otherwise = returnRn () +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- +-- Helpers +warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mapRn_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance groups = equivClasses cmp names - (_,prov1) `cmp` (_,prov2) = prov1 `cmp_prov` prov2 + (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - cmp_prov (LocalDef _ _) (NonLocalDef _ _) = LT - cmp_prov (LocalDef loc1 _) (LocalDef loc2 _) = loc1 `compare` loc2 - cmp_prov (NonLocalDef (UserImport m1 loc1 _) _) - (NonLocalDef (UserImport m2 loc2 _) _) = - (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) - cmp_prov (NonLocalDef _ _) (LocalDef _ _) = GT - -- In-scope NonLocalDefs must have UserImport info on them ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () warnUnusedGroup names - | null filtered_names = returnRn () - | not is_local = returnRn () + | null filtered_names = returnM () + | not is_local = returnM () | otherwise - = pushSrcLocRn def_loc $ - addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map ppr filtered_names)))] + = addSrcLoc def_loc $ + addWarn $ + sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] where filtered_names = filter reportable names (name1, prov1) = head filtered_names (is_local, def_loc, msg) = case prov1 of - LocalDef loc _ -> (True, loc, text "Defined but not used") + 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 @@ -750,17 +998,12 @@ warnUnusedGroup names \begin{code} addNameClashErrRn rdr_name (np1:nps) - = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), + = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) 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 = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), @@ -772,16 +1015,26 @@ unknownNameErr name where flavour = occNameFlavour (rdrNameOcc name) +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), - quotes (ppr name), - ptext SLIT("in"), + = addSrcLoc loc $ + addErr (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)) + = addSrcLoc loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ - (ptext SLIT("in") <+> descriptor)) + descriptor) + +warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) + = ifOptM Opt_WarnDeprecations $ + addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> + quotes (ppr name) <+> text "is deprecated:", + nest 4 (ppr txt) ]) \end{code} +