\begin{code}
module RnEnv (
newTopSrcBinder,
- lookupBndrRn,lookupTopBndrRn,
- lookupOccRn, lookupGlobalOccRn,
- lookupTopFixSigNames, lookupSrcOcc_maybe,
- lookupFixityRn, lookupSigOccRn, lookupInstDeclBndr,
- lookupSyntaxName, lookupSyntaxNames, lookupImportedName,
+ lookupLocatedBndrRn, lookupBndrRn,
+ lookupLocatedTopBndrRn, lookupTopBndrRn,
+ lookupLocatedOccRn, lookupOccRn,
+ lookupLocatedGlobalOccRn, lookupGlobalOccRn,
+ lookupLocalDataTcNames, lookupSrcOcc_maybe,
+ lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
+ lookupLocatedInstDeclBndr,
+ lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
- bindLocalsRn, bindLocalsFV, bindLocatedLocalsRn,
- bindPatSigTyVars, bindPatSigTyVarsFV,
+ bindLocatedLocalsFV, bindLocatedLocalsRn,
+ bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindLocalFixities,
checkDupNames, mapFvRn,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, unknownNameErr
+ dataTcOccs, unknownNameErr,
) where
#include "HsVersions.h"
-import LoadIface ( loadSrcInterface )
+import LoadIface ( loadHomeInterface, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
-import HsSyn
-import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
+import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
+ LHsTyVarBndr, LHsType,
+ Fixity, hsLTyVarLocNames, replaceTyVarName )
+import RdrHsSyn ( extractHsTyRdrTyVars )
+import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig,
mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
pprGlobalRdrEnv, lookupGRE_RdrName,
isExact_maybe, isSrcRdrName,
GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv,
isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv,
- Provenance(..), pprNameProvenance, ImportSpec(..)
+ Provenance(..), pprNameProvenance,
+ importSpecLoc, importSpecModule
)
-import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcRnMonad
-import Name ( Name, nameIsLocalOrFrom, mkInternalName,
- nameSrcLoc, nameOccName, nameModuleName, nameParent )
+import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
+ nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
import NameSet
-import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
-import Module ( Module, ModuleName, moduleName, mkHomeModule )
-import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE )
+import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
+ reportIfUnused )
+import Module ( Module )
+import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey )
import UniqSupply
import BasicTypes ( IPName, mapIPName )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
+ srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine )
import Outputable
-import ListSetOps ( removeDups, equivClasses )
-import List ( nub )
-import CmdLineOpts
-import FastString ( FastString )
+import Util ( sortLe )
+import ListSetOps ( removeDups )
+import List ( nubBy )
+import Monad ( when )
+import DynFlags
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-newTopSrcBinder :: Module -> Maybe Name -> (RdrName, SrcLoc) -> RnM Name
-newTopSrcBinder mod mb_parent (rdr_name, loc)
+newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name
+newTopSrcBinder this_mod mb_parent (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
- = returnM 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
+ ASSERT2( isExternalName name, ppr name )
+ do checkErr (this_mod == nameModule name)
+ (badOrigBinding rdr_name)
+ returnM name
+
| isOrig rdr_name
- = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name )
+ = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+ (badOrigBinding rdr_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
+ -- We can get built-in syntax showing up here too, sadly. If you type
+ -- data T = (,,,)
+ -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon
+ -- uses setRdrNameSpace to make it into a data constructors. At that point
+ -- the nice Exact name for the TyCon gets swizzled to an Orig name.
+ -- Hence the badOrigBinding error message.
--
- -- 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,
+ -- Except for the ":Main.main = ..." definition inserted into
+ -- the Main module; ugh!
+
+ -- Because of this latter case, we call newGlobalBinder with a 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 loc
+ newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent
+ (srcSpanStart loc) --TODO, should pass the whole span
| otherwise
- = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent loc
+ = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc)
where
- rdr_mod = rdrNameModule rdr_name
+ rdr_mod = rdrNameModule rdr_name
\end{code}
%*********************************************************
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 setSrcSpan'd
lookupBndrRn rdr_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.
lookupTopBndrRn 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 == nameModuleName name)
- (badOrigBinding rdr_name) `thenM_`
- returnM name
+ = 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
- = getSrcLocM `thenM` \ loc ->
- newGlobalBinder (mkHomeModule (rdrNameModule rdr_name))
- (rdrNameOcc rdr_name) Nothing loc
+ = do { loc <- getSrcSpanM
+ ; newGlobalBinder (rdrNameModule rdr_name)
+ (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) }
| otherwise
= do { mb_gre <- lookupGreLocalRn rdr_name
Nothing -> unboundName rdr_name
Just gre -> returnM (gre_name gre) }
--- lookupSigOccRn is used for type signatures and pragmas
+-- lookupLocatedSigOccRn is used for type signatures and pragmas
-- Is this valid?
-- module A
-- import M( f )
-- 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 -> RnM 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
-- Occurrences
--------------------------------------------------
+lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedOccRn = wrapLocM lookupOccRn
+
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
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
Nothing ->
-- We allow qualified names on the command line to refer to
- -- *any* name exported by any module in scope, just as if
+ -- *any* name exported by any module in scope, just as if
-- there was an "import qualified M" declaration for every
-- module.
getModule `thenM` \ mod ->
where
lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env)
-lookupGreRn_help :: RdrName -- Only used in error message
+lookupGreRn_help :: RdrName -- Only used in error message
-> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function
-> RnM (Maybe GlobalRdrElt)
-- Checks for exactly one match; reports deprecations
= do { env <- getGlobalRdrEnv
; case lookup env of
[] -> returnM Nothing
- [gre] -> case gre_deprec gre of
- Nothing -> returnM (Just gre)
- Just _ -> do { warnDeprec gre
- ; returnM (Just gre) }
+ [gre] -> returnM (Just gre)
gres -> do { addNameClashErrRn rdr_name gres
; returnM (Just (head gres)) } }
mod = rdrNameModule rdr_name
occ = rdrNameOcc rdr_name
in
+ -- Note: we want to behave as we would for a source file import here,
+ -- and respect hiddenness of modules/packages, hence loadSrcInterface.
loadSrcInterface doc mod False `thenM` \ iface ->
case [ (mod,occ) |
%*********************************************************
\begin{code}
-lookupTopFixSigNames :: RdrName -> RnM [Name]
+lookupLocalDataTcNames :: RdrName -> RnM [Name]
-- GHC extension: look up both the tycon and data con
-- for con-like things
-lookupTopFixSigNames rdr_name
+-- Complain if neither is in scope
+lookupLocalDataTcNames 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
= do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name)
- ; return [gre_name gre | Just gre <- mb_gres] }
+ ; case [gre_name gre | Just gre <- mb_gres] of
+ [] -> do { addErr (unknownNameErr rdr_name)
+ ; return [] }
+ names -> return names
+ }
--------------------------------
-bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a
+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
| 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, (FixItem (rdrNameOcc v) fix src_loc))
+ rn_sig (FixitySig lv@(L loc v) fix)
+ = addLocM lookupBndrRn lv `thenM` \ new_v ->
+ returnM (new_v, (FixItem (rdrNameOcc v) fix loc))
\end{code}
--------------------------------
-- 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 ->
+ --
+ -- loadHomeInterface will find B.hi even if B is a hidden module,
+ -- and that's what we want.
+ loadHomeInterface doc name `thenM` \ iface ->
returnM (mi_fix_fn iface (nameOccName name))
where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
- name_mod = nameModuleName name
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
+
+---------------
+lookupTyFixityRn :: Located Name -> RnM Fixity
+lookupTyFixityRn (L loc n)
+ = doptM Opt_GlasgowExts `thenM` \ glaExts ->
+ when (not glaExts)
+ (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_`
+ lookupFixityRn n
+---------------
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]
+ | Just n <- isExact_maybe rdr_name -- Ghastly special case
+ , n `hasKey` consDataConKey = [rdr_name] -- see note below
+ | isDataOcc occ = [rdr_name_tc, rdr_name]
+ | otherwise = [rdr_name]
where
occ = rdrNameOcc rdr_name
rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName,
+-- and setRdrNameSpace generates an Orig, which is fine
+-- But it's not fine for (:), because there *is* no corresponding type
+-- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll
+-- appear to be in scope (because Orig's simply allocate a new name-cache
+-- entry) and then we get an error when we use dataTcOccs in
+-- TcRnDriver.tcRnGetInfo. Large sigh.
\end{code}
%************************************************************************
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
- * NPlusKPatIn
+ * NPlusKPat
* HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
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 :: Name -- The standard name
+ -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude ->
- if not no_prelude then normal_case
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_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)
+ returnM (HsVar usr_name, unitFV usr_name)
where
- normal_case = returnM (std_name, emptyFVs)
+ normal_case = returnM (HsVar std_name, emptyFVs)
-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
+lookupSyntaxTable :: [Name] -- Standard names
+ -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
+lookupSyntaxTable std_names
+ = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude ->
+ if implicit_prelude then normal_case
else
-- Get the similarly named thing from the local environment
mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
%*********************************************************
\begin{code}
-newLocalsRn :: [(RdrName,SrcLoc)]
- -> RnM [Name]
+newLocalsRn :: [Located RdrName] -> RnM [Name]
newLocalsRn rdr_names_w_loc
- = newUniqueSupply `thenM` \ us ->
- let
- uniqs = uniqsFromSupply us
- names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc
- | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
- ]
- in
- returnM 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)]
+ -> [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
- = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc )
- -- We only bind unqualified names here
- -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName
-
- -- Check for duplicate names
+ = -- Check for duplicate names
checkDupNames doc_str rdr_names_w_loc `thenM_`
-- Warn about shadowing, but only in source modules
(enclosed_scope names)
+bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= getLocalRdrEnv `thenM` \ name_env ->
setLocalRdrEnv (extendLocalRdrEnv name_env names)
enclosed_scope
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
- = bindLocalNames names $
- enclosed_scope `thenM` \ (thing, fvs) ->
- returnM (thing, delListFromNameSet fvs names)
+ = do { (result, fvs) <- bindLocalNames names enclosed_scope
+ ; returnM (result, delListFromNameSet fvs names) }
-------------------------------------
-bindLocalsRn doc rdr_names enclosed_scope
- = getSrcLocM `thenM` \ loc ->
- bindLocatedLocalsRn doc
- (rdr_names `zip` repeat loc)
- enclosed_scope
-
-- binLocalsFVRn is the same as bindLocalsRn
-- except that it deals with free vars
-bindLocalsFV doc rdr_names enclosed_scope
- = bindLocalsRn doc rdr_names $ \ 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] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
- -- This tiresome function is used only in rnSourceDecl on InstDecl
-extendTyVarEnvFVRn tyvars enclosed_scope
- = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) ->
- returnM (thing, delListFromNameSet fvs tyvars)
-
-bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([HsTyVarBndr Name] -> RnM a)
+bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
+ -> ([LHsTyVarBndr Name] -> RnM a)
-> RnM a
+-- Haskell-98 binding of type variables; e.g. within a data type decl
bindTyVarsRn doc_str tyvar_names enclosed_scope
- = getSrcLocM `thenM` \ loc ->
- let
- located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names]
+ = let
+ located_tyvars = hsLTyVarLocNames tyvar_names
in
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
- enclosed_scope (zipWith replaceTyVarName tyvar_names names)
+ enclosed_scope (zipWith replace tyvar_names names)
+ where
+ replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
-bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a
+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 ->
- getSrcLocM `thenM` \ loc ->
- let
- forall_tyvars = nub [ tv | ty <- tys,
- tv <- extractHsTyRdrTyVars ty,
- not (tv `elemLocalRdrEnv` name_env)
- ]
+ = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside []
+ else
+ do { name_env <- getLocalRdrEnv
+ ; let locd_tvs = [ tv | ty <- tys
+ , tv <- extractHsTyRdrTyVars ty
+ , not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ nubbed_tvs = nubBy eqLocated locd_tvs
-- 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_sig located_tyvars thing_inside
+ ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }}
+ where
+ doc_sig = text "In a pattern type-signature"
-bindPatSigTyVarsFV :: [RdrNameHsType]
+bindPatSigTyVarsFV :: [LHsType RdrName]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindPatSigTyVarsFV tys thing_inside
thing_inside `thenM` \ (result,fvs) ->
returnM (result, fvs `delListFromNameSet` tvs)
+bindSigTyVarsFV :: [Name]
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+bindSigTyVarsFV tvs thing_inside
+ = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside
+ else
+ bindLocalNamesFV tvs thing_inside }
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+ -- This function is used only in rnSourceDecl on InstDecl
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
-------------------------------------
checkDupNames :: SDoc
- -> [(RdrName, SrcLoc)]
+ -> [Located RdrName]
-> RnM ()
checkDupNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
mappM_ (dupNamesErr doc_str) dups
where
- (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc
+ (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
-------------------------------------
-checkShadowing doc_str rdr_names_w_loc
+checkShadowing doc_str loc_rdr_names
= getLocalRdrEnv `thenM` \ local_env ->
getGlobalRdrEnv `thenM` \ global_env ->
let
- check_shadow (rdr_name,loc)
+ check_shadow (L loc rdr_name)
| rdr_name `elemLocalRdrEnv` local_env
|| not (null (lookupGRE_RdrName rdr_name global_env ))
- = addSrcLoc loc $ addWarn (shadowedNameWarn doc_str rdr_name)
+ = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name)
| otherwise = returnM ()
in
- mappM_ check_shadow rdr_names_w_loc
+ mappM_ check_shadow loc_rdr_names
\end{code}
%************************************************************************
\begin{code}
-warnUnusedModules :: [ModuleName] -> RnM ()
+warnUnusedModules :: [(Module,SrcSpan)] -> RnM ()
warnUnusedModules mods
- = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods)
+ = ifOptM Opt_WarnUnusedImports (mappM_ bleat 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 instances visible in") <+>
- quotes (ppr m))]
+ bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod)
+ mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m)
+ <+> text "is imported, but nothing from it is used,",
+ nest 2 (ptext SLIT("except perhaps instances visible in")
+ <+> quotes (ppr m)),
+ ptext SLIT("To suppress this warning, use:")
+ <+> ptext SLIT("import") <+> ppr m <> parens empty ]
+
warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
-------------------------
-- Helpers
-warnUnusedGREs gres = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres]
-warnUnusedLocals names = warnUnusedBinds [(n,Nothing) | n<-names]
+warnUnusedGREs gres
+ = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres]
-warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM ()
-warnUnusedBinds names
- = mappM_ warnUnusedGroup groups
- where
- -- Group by provenance
- groups = equivClasses cmp (filter reportable names)
- (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2
-
- reportable (name,_) = reportIfUnused (nameOccName name)
+warnUnusedLocals names
+ = warnUnusedBinds [(n,Nothing) | n<-names]
+warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM ()
+warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names)
+ where reportable (name,_)
+ | isWiredInName name = False -- Don't report unused wired-in names
+ -- Otherwise we get a zillion warnings
+ -- from Data.Tuple
+ | otherwise = reportIfUnused (nameOccName name)
-------------------------
-warnUnusedGroup :: [(Name,Maybe Provenance)] -> RnM ()
-warnUnusedGroup names
- = addSrcLoc def_loc $
- addWarn $
- sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))]
+warnUnusedName :: (Name, Maybe Provenance) -> RnM ()
+warnUnusedName (name, prov)
+ = addWarnAt loc $
+ sep [msg <> colon,
+ nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
+ <+> quotes (ppr name)]
+ -- TODO should be a proper span
where
- (name1, prov1) = head names
- loc1 = nameSrcLoc name1
- (def_loc, msg) = case prov1 of
- Just (Imported is _) -> (is_loc imp_spec, imp_from (is_mod imp_spec))
- where
- imp_spec = head is
- other -> (loc1, unused_msg)
+ (loc,msg) = case prov of
+ Just (Imported is)
+ -> (importSpecLoc imp_spec, imp_from (importSpecModule 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"
ptext SLIT("shadows an existing binding")]
$$ doc
-unknownNameErr name
- = sep [text flavour <+> ptext SLIT("not in scope:"), quotes (ppr name)]
- where
- flavour = occNameFlavour (rdrNameOcc name)
+unknownNameErr rdr_name
+ = sep [ptext SLIT("Not in scope:"),
+ nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+ <+> quotes (ppr rdr_name)]
unknownInstBndrErr cls op
= quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls)
= ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
-- The rdrNameOcc is because we don't want to print Prelude.(,)
-dupNamesErr descriptor ((name,loc) : dup_things)
- = addSrcLoc loc $
- addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
- $$
- descriptor)
-warnDeprec :: GlobalRdrElt -> RnM ()
-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) ])
+dupNamesErr :: SDoc -> [Located RdrName] -> RnM ()
+dupNamesErr descriptor located_names
+ = setSrcSpan big_loc $
+ addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1),
+ locations,
+ descriptor])
+ where
+ L _ name1 = head located_names
+ locs = map getLoc located_names
+ big_loc = foldr1 combineSrcSpans locs
+ one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc
+ locations | one_line = empty
+ | otherwise = ptext SLIT("Bound at:") <+>
+ vcat (map ppr (sortLe (<=) locs))
+
+infixTyConWarn op
+ = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op),
+ ftext FSLIT("Use -fglasgow-exts to avoid this warning")]
\end{code}
projects / ghc-hetmet.git / blobdiff