X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=417d873092dc73bfcd1418c4e02d8a01ba71cb2a;hb=568d3f41cb2da3fe4887e13d69f152d66cbcb755;hp=582f0aad62020d74a150d69115ef7eaeeebc4a14;hpb=5e6242927839c8ddc73a55eb7828c0b7e4cc3ab2;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 582f0aa..417d873 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -4,206 +4,171 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -module RnEnv where -- Export everything +module RnEnv ( + newTopSrcBinder, + lookupLocatedBndrRn, lookupBndrRn, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocatedGlobalOccRn, lookupGlobalOccRn, + lookupTopFixSigNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupLocatedSigOccRn, + lookupLocatedInstDeclBndr, + lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + + newLocalsRn, newIPNameRn, + bindLocalNames, bindLocalNamesFV, + bindLocatedLocalsFV, bindLocatedLocalsRn, + bindPatSigTyVars, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalFixities, + + checkDupNames, mapFvRn, + warnUnusedMatches, warnUnusedModules, warnUnusedImports, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, unknownNameErr, + ) where #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles - -import HscTypes ( ModIface(..) ) +import LoadIface ( loadSrcInterface ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn -import RnHsSyn ( RenamedHsDecl ) -import RdrHsSyn ( RdrNameIE ) +import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv + mkRdrUnqual, setRdrNameSpace, rdrNameOcc, + pprGlobalRdrEnv, lookupGRE_RdrName, + isExact_maybe, isSrcRdrName, + GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, + isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, + Provenance(..), pprNameProvenance, ImportSpec(..) ) import HsTypes ( hsTyVarName, replaceTyVarName ) -import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - Deprecations(..), lookupDeprec - ) -import RnMonad -import Name ( Name, - getSrcLoc, - mkLocalName, mkGlobalName, - mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, mkNameEnv - ) -import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import TcRnMonad +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, + nameSrcLoc, nameOccName, nameModuleName, nameParent ) import NameSet -import OccName ( OccName, occNameUserString, occNameFlavour ) -import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) -import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) -import Type ( funTyCon ) -import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap, - derivingOccurrences, - mAIN_Name, pREL_MAIN_Name, - ioTyConName, printName, - unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName - ) -import FiniteMap +import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused, + isVarOcc ) +import Module ( Module, ModuleName, moduleName, mkHomeModule ) +import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) import UniqSupply -import SrcLoc ( SrcLoc, noSrcLoc ) +import BasicTypes ( IPName, mapIPName ) +import SrcLoc ( srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan ) import Outputable -import ListSetOps ( removeDups, equivClasses ) -import Util ( sortLt ) -import List ( nub ) -import UniqFM ( lookupWithDefaultUFM ) -import Maybes ( orElse ) +import ListSetOps ( removeDups ) +import List ( nubBy ) import CmdLineOpts import FastString ( FastString ) \end{code} %********************************************************* %* * -\subsection{Making new names} + Source-code binders %* * %********************************************************* \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 - - -- 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) - 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 - - -- A hit in the cache! We are at the binding site of the name, and - -- this is the moment when we know all about - -- a) the Name's host Module (in particular, which - -- package it comes from) - -- 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 (name_supply {nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` - returnRn 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 (nsUniqs name_supply) - uniq = uniqFromSupply us1 - new_name = mkGlobalName uniq mod occ loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` - returnRn new_name - - -newGlobalName :: ModuleName -> OccName -> RnM d 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) - -- The place-holder Name doesn't have the right SrcLoc, and its - -- Module won't have the right Package either. - -- - -- (We have to pass a ModuleName, not a Module, because we may be - -- simply looking at an occurrence M.x in an interface file.) - -- - -- This means that a renamed program may have incorrect info - -- on implicitly-imported occurrences, but the correct info on the - -- *binding* declaration. It's the type checker that propagates the - -- correct information to all the occurrences. - -- Since implicitly-imported names never occur in error messages, - -- it doesn't matter that we get the correct info in place till later, - -- (but since it affects DLL-ery it does matter that we get it right - -- in the end). -newGlobalName mod_name occ - = 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_` - returnRn name - - Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` - returnRn name - where - (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` \ 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 - 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) +newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name +newTopSrcBinder mod mb_parent (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = returnM name + + | isOrig rdr_name + = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module + -- + -- Because of this latter case, we take the module from the RdrName, + -- not from the environment. In principle, it'd be fine to have an + -- arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span + + | otherwise + = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) + where + rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* %* * -\subsection{Looking up names} + Source code occurrences %* * %********************************************************* Looking up a name in the RnEnv. \begin{code} +lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedBndrRn = wrapLocM lookupBndrRn + +lookupBndrRn :: RdrName -> RnM Name +-- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd lookupBndrRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> - case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +lookupTopBndrRn :: RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- 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 +-- 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 in Haskell, +-- but there can be if we have read in an external-Core file. +-- The Haskell parser checks for the illegal qualified name in Haskell +-- source files, so we don't need to do so here. + lookupTopBndrRn rdr_name - = 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) - --- lookupSigOccRn is used for type signatures and pragmas + | Just name <- isExact_maybe rdr_name + -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- + -- 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 (isInternalName name || moduleName mod == nameModuleName name) + (badOrigBinding rdr_name) `thenM_` + returnM name + + | isOrig rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = do + loc <- getSrcSpanM + newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) + + | otherwise + = do { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Nothing -> unboundName rdr_name + Just gre -> returnM (gre_name gre) } + +-- lookupLocatedSigOccRn is used for type signatures and pragmas -- Is this valid? -- module A -- import M( f ) @@ -213,235 +178,330 @@ 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 = lookupBndrRn +lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedSigOccRn = lookupLocatedBndrRn + +-- lookupInstDeclBndr is used for the binders in an +-- instance declaration. Here we use the class name to +-- disambiguate. + +lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) + +lookupInstDeclBndr :: Name -> RdrName -> RnM Name +lookupInstDeclBndr cls_name rdr_name + | isUnqual rdr_name -- Find all the things the rdr-name maps to + = do { -- and pick the one with the right parent name + let { is_op gre = cls_name == nameParent (gre_name gre) + ; occ = rdrNameOcc rdr_name + ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } + ; mb_gre <- lookupGreRn_help rdr_name lookup_fn + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) + ; return (mkUnboundName rdr_name) } } + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + -- NB: qualified names are rejected by the parser + lookupImportedName rdr_name + +newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) +newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn -- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnMS Name +lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> - case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name +lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn + +lookupGlobalOccRn :: RdrName -> RnM 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 -> - if (isInterfaceMode mode) - then lookupIfaceName rdr_name - else - - getGlobalNameEnv `thenRn` \ global_env -> - 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 + | not (isSrcRdrName rdr_name) + = lookupImportedName rdr_name + + | otherwise + = -- First look up the name in the normal environment. + lookupGreRn rdr_name `thenM` \ mb_gre -> + case mb_gre of { + Just gre -> returnM (gre_name gre) ; + Nothing -> + + -- 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. + getModule `thenM` \ mod -> + if isQual rdr_name && mod == iNTERACTIVE then + -- This test is not expensive, + lookupQualifiedName rdr_name -- and only happens for failed lookups + else + unboundName rdr_name } + +lookupImportedName :: RdrName -> TcRnIf m n Name +-- Lookup the occurrence of an imported name +-- The RdrName is *always* qualified or Exact +-- Treat it as an original name, and conjure up the Name +-- Usually it's Exact or Orig, but it can be Qual if it +-- comes from an hi-boot file. (This minor infelicity is +-- just to reduce duplication in the parser.) +lookupImportedName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code + = returnM n + + | otherwise -- Always Orig, even when reading a .hi-boot file + = ASSERT( not (isUnqual rdr_name) ) + lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +unboundName :: RdrName -> RnM Name +unboundName rdr_name + = do { addErr (unknownNameErr rdr_name) + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext SLIT("Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + ; returnM (mkUnboundName rdr_name) } + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure +lookupSrcOcc_maybe rdr_name + = do { mb_gre <- lookupGreRn rdr_name + ; case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) } + +------------------------- +lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> returnM Nothing + [gre] -> returnM (Just gre) + gres -> do { addNameClashErrRn rdr_name gres + ; returnM (Just (head gres)) } } + +------------------------------ +-- GHCi support +------------------------------ + +-- 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 :: RdrName -> RnM Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod ImportBySystem `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 + loadSrcInterface doc mod False `thenM` \ iface -> + + case [ (mod,occ) | + (mod,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + name == occ ] of + ((mod,occ):ns) -> ASSERT (null ns) + lookupOrig mod occ + _ -> unboundName rdr_name + where + doc = ptext SLIT("Need to find") <+> ppr rdr_name +\end{code} +%********************************************************* +%* * + Fixities +%* * +%********************************************************* + +\begin{code} +lookupTopFixSigNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +lookupTopFixSigNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too | otherwise - = case lookupRdrEnv global_env rdr_name of - 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 + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; return [gre_name gre | Just gre <- mb_gres] } + +-------------------------------- +bindLocalFixities :: [FixitySig RdrName] -> 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 lv@(L loc v) fix) + = addLocM lookupBndrRn lv `thenM` \ new_v -> + returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) \end{code} -@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. +-------------------------------- +lookupFixity is a bit strange. -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). +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv - \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} +* Imported fixities are found in the HIT or PIT -\begin{code} -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. +* 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 -> + traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` + 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. + loadSrcInterface doc name_mod False `thenM` \ iface -> + returnM (mi_fix_fn iface (nameOccName name)) + where + doc = ptext SLIT("Checking fixity for") <+> ppr name + name_mod = nameModuleName name + +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. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} +%************************************************************************ +%* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_NoImplicitPrelude dynamic flag. -%********************************************************* -%* * -\subsection{Implicit free vars and sugar names} -%* * -%********************************************************* + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally -@addImplicitFVs@ 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) +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 + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case + else + -- Get the similarly named thing from the local environment + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, unitFV usr_name) where - extra_implicits Nothing -- Compiling an expression - = returnRn (unitFV printName) -- print :: a -> IO () may be needed later - - 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 - - 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 (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon]) - -- Add occurrences for Int, and (), because they - -- are the types to which ambigious type variables may be defaulted by - -- the type checker; so they won't always appear explicitly. - -- [The () one is a GHC extension for defaulting CCall results.] - -- ALSO: funTyCon, since it occurs implicitly everywhere! - -- (we don't want to be bothered with making funTyCon a - -- free var at every function application!) - -- Double is dealt with separately in getGates -\end{code} + normal_case = returnM (std_name, emptyFVs) -\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) - -rnSyntaxNames gbl_env source_fvs - = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> - if not no_prelude then - returnRn (source_fvs, vanillaSyntaxMap) +lookupSyntaxNames :: [Name] -- Standard names + -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames std_names + = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> + if not no_prelude then normal_case else + -- Get the similarly named thing from the local environment + mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - -- 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') - 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) + returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names) + where + normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs) \end{code} @@ -452,426 +512,126 @@ rnSyntaxNames gbl_env source_fvs %********************************************************* \begin{code} -newLocalsRn :: [(RdrName,SrcLoc)] - -> RnMS [Name] +newLocalsRn :: [Located RdrName] -> RnM [Name] 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 - names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc - | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs - ] - in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` - returnRn names - + = newUniqueSupply `thenM` \ us -> + returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) + where + mk (L loc rdr_name) uniq + | Just name <- isExact_maybe rdr_name = name + -- This happens in code generated by Template Haskell + | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + -- We only bind unqualified names here + -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName + mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS a) - -> RnMS a + -> [Located RdrName] + -> ([Name] -> RnM a) + -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ name_env -> - - -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` - - doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow -> + = -- Check for duplicate names + checkDupNames doc_str rdr_names_w_loc `thenM_` -- 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_` - - newLocalsRn rdr_names_w_loc `thenRn` \ names -> - let - new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names) - in - setLocalNameEnv new_local_env (enclosed_scope names) + ifOptM Opt_WarnNameShadowing + (checkShadowing doc_str rdr_names_w_loc) `thenM_` - 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) - -- * one at a time - -- * no checks for shadowing - -- * always imported - -- * deal with free vars -bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ name_supply -> - let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkLocalName uniq (rdrNameOcc rdr_name) loc - in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` - let - new_name_env = extendRdrEnv name_env rdr_name name - in - setLocalNameEnv new_name_env (enclosed_scope name) + -- Make fresh Names and extend the environment + newLocalsRn rdr_names_w_loc `thenM` \ names -> + getLocalRdrEnv `thenM` \ local_env -> + setLocalRdrEnv (extendLocalRdrEnv local_env names) + (enclosed_scope 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 `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -bindLocalRn doc rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> - ASSERT( null ns ) - enclosed_scope n - -bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - bindLocatedLocalsRn doc - (rdr_names `zip` repeat loc) - enclosed_scope - -- binLocalsFVRn is the same as bindLocalsRn -- 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) +bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) + -> RnM (a, FreeVars) +bindLocatedLocalsFV doc rdr_names enclosed_scope + = bindLocatedLocalsRn doc rdr_names $ \ names -> + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +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 +bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr 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 -> - let - located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] + = let + located_tyvars = [L loc (hsTyVarName tv) | L 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 replace tyvar_names names) + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) + +bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a + -- Find the type variables in the pattern type + -- signatures that must be brought into scope +bindPatSigTyVars tys thing_inside + = getLocalRdrEnv `thenM` \ name_env -> let - located_tyvars = [(tv, loc) | tv <- tyvar_names] + located_tyvars = nubBy eqLocated [ tv | ty <- tys, + tv <- extractHsTyRdrTyVars ty, + not (unLoc tv `elemLocalRdrEnv` name_env) + ] + -- The 'nub' is important. For example: + -- f (x :: t) (y :: t) = .... + -- We don't want to complain about binding t twice! + + 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 thing_inside +bindPatSigTyVarsFV :: [LHsType RdrName] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- -checkDupOrQualNames, checkDupNames :: SDoc - -> [(RdrName, SrcLoc)] - -> RnM d () - -- 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_` - checkDupNames doc_str rdr_names_w_loc - where - quals = filter (isQual . fst) rdr_names_w_loc - +checkDupNames :: SDoc + -> [Located RdrName] + -> RnM () checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group - mapRn_ (dupNamesErr doc_str) dups - where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc -\end{code} - - -%************************************************************************ -%* * -\subsection{GlobalRdrEnv} -%* * -%************************************************************************ - -\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 - -> Deprecations - -> GlobalRdrEnv - -mkGlobalRdrEnv this_mod unqual_imp qual_imp hides - mk_provenance avails deprecs - = gbl_env2 + mappM_ (dupNamesErr doc_str) dups 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 the things that are available - gbl_env1 = foldl add_avail emptyRdrEnv avails - - -- Delete things that are hidden - gbl_env2 = foldl del_avail gbl_env1 hides - - 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 - 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} -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 - -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 :: [GlobalRdrElt] -- Old - -> [GlobalRdrElt] -- New - -> [GlobalRdrElt] -combine_globals ns_old ns_new -- ns_new is often short - = foldr add ns_old ns_new - where - add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates - | otherwise = n:ns - - choose n m | n `beats` m = n - | otherwise = m - - (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm - - 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, -because they might be two separate, local defns and we want to report -and error for that, {\em not} eliminate a duplicate. - -On the other hand, if you import the same name from two different -import statements, we {\em do} want to eliminate the duplicate, not report -an error. - -If a module imports itself then there might be a local defn and an imported -defn of the same name; in this case the names will compare as equal, but -will still have different provenances. - - -@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 - = (`elemNameSet` unqual_names) - where - 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} - - -%************************************************************************ -%* * -\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 [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 - -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 - -------------------------------------- -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 + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc ------------------------------------- -groupAvails :: Module -> Avails -> [(ModuleName, Avails)] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -groupAvails this_mod avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM - ] - where - groupFM :: FiniteMap FastString Avails - -- 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'] - where - 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) - -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 +checkShadowing doc_str loc_rdr_names + = getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> + let + check_shadow (L loc rdr_name) + | rdr_name `elemLocalRdrEnv` local_env + || not (null (lookupGRE_RdrName rdr_name global_env )) + = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + | otherwise = returnM () + in + mappM_ check_shadow loc_rdr_names \end{code} @@ -883,11 +643,11 @@ sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) \begin{code} -- 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} @@ -898,108 +658,87 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM d () +warnUnusedModules :: [ModuleName] -> RnM () warnUnusedModules mods - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then mapRn_ (addWarnRn . unused_mod) mods - else returnRn () + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where 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") <+> + parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports :: [(Name,Provenance)] -> RnM d () -warnUnusedImports names - = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> - if warn then warnUnusedBinds names else returnRn () - -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedLocalBinds names - = doptRn Opt_WarnUnusedBinds `thenRn` \ warn -> - if warn then warnUnusedBinds [(n,LocalDef) | n<-names] - else returnRn () +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedMatches names - = doptRn Opt_WarnUnusedMatches `thenRn` \ warn -> - if warn then warnUnusedGroup [(n,LocalDef) | n<-names] - else returnRn () +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- +-- Helpers +warnUnusedGREs gres + = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedBinds :: [(Name,Provenance)] -> RnM d () -warnUnusedBinds names - = mapRn_ warnUnusedGroup groups - where - -- Group by provenance - groups = equivClasses cmp names - (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - +warnUnusedLocals names + = warnUnusedBinds [(n,Nothing) | n<-names] + +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) + where reportable (name,_) = reportIfUnused (nameOccName name) ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> RnM d () -warnUnusedGroup names - | null filtered_names = returnRn () - | not is_local = returnRn () - | otherwise - = pushSrcLocRn def_loc $ - addWarnRn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] +warnUnusedName :: (Name, Maybe Provenance) -> RnM () +warnUnusedName (name, prov) + = addWarnAt loc (sep [msg <> colon, nest 4 (ppr name)]) + -- TODO should be a proper span where - filtered_names = filter reportable names - (name1, prov1) = head filtered_names - (is_local, def_loc, msg) - = case prov1 of - LocalDef -> (True, getSrcLoc name1, text "Defined but not used") - - NonLocalDef (UserImport mod loc _) - -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") - - reportable (name,_) = case occNameUserString (nameOccName name) of - ('_' : _) -> False - zz_other -> True - -- Haskell 98 encourages compilers to suppress warnings about - -- unused names in a pattern if they start with "_". + (loc,msg) = case prov of + Just (Imported is _) -> + ( is_loc (head is), imp_from (is_mod imp_spec) ) + where + imp_spec = head is + other -> + ( srcLocSpan (nameSrcLoc name), unused_msg ) + + unused_msg = text "Defined but not used" + imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" \end{code} \begin{code} addNameClashErrRn rdr_name (np1:nps) - = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + = 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 (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov + mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn shadow +shadowedNameWarn doc shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] + $$ doc unknownNameErr name - = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] + = sep [ptext SLIT("Not in scope:"), + if isVarOcc occ_name then quotes (ppr name) + else text (occNameFlavour occ_name) + <+> quotes (ppr name)] where - flavour = occNameFlavour (rdrNameOcc name) - -qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"), - quotes (ppr name), - ptext SLIT("in"), - descriptor]) - -dupNamesErr descriptor ((name,loc) : dup_things) - = pushSrcLocRn loc $ - addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + occ_name = rdrNameOcc name + +unknownInstBndrErr cls op + = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) + +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + +dupNamesErr descriptor (L loc name : dup_things) + = addSrcSpan loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ - (ptext SLIT("in") <+> descriptor)) - -warnDeprec :: Name -> DeprecTxt -> RnM d () -warnDeprec name txt - = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> - if not warn_drs then returnRn () else - addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> - quotes (ppr name) <+> text "is deprecated:", - nest 4 (ppr txt) ]) + descriptor) \end{code}