%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-2006
%
\section[RnEnv]{Environment manipulation for the renamer monad}
\begin{code}
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupSubBndr,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
bindLocalName, bindLocalNames, bindLocalNamesFV,
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
checkDupRdrNames, checkDupAndShadowedRdrNames,
checkDupNames, checkDupAndShadowedNames,
addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
) where
#include "HsVersions.h"
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache )
import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
import HscTypes ( NameCache(..), availNames, ModIface(..), FixItem(..), lookupFixity)
import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
import TcRnMonad
import Id ( isRecordSelector )
import Name
import NameSet
import NameEnv
import Module ( ModuleName, moduleName )
import UniqFM
import DataCon ( dataConFieldLabels )
import PrelNames ( mkUnboundName, rOOT_MAIN, consDataConKey, forall_tv_RDR )
import Unique
import BasicTypes
import ErrUtils ( Message )
import SrcLoc
import Outputable
import Util
import Maybes
import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
import Data.List
import qualified Data.Set as Set
\end{code}
\begin{code}
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)
\end{code}
%*********************************************************
%* *
Source-code binders
%* *
%*********************************************************
\begin{code}
newTopSrcBinder :: Located RdrName -> RnM Name
newTopSrcBinder (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
=
if isExternalName name then
do { this_mod <- getModule
; unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name))
; return name }
else
do { let occ = nameOccName name
; occ `seq` return ()
; this_mod <- getModule
; updNameCache $ \ ns ->
let name' = mkExternalName (nameUnique name) this_mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) this_mod occ name' }
in (ns', name') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { this_mod <- getModule
; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(addErrAt loc (badOrigBinding rdr_name))
; newGlobalBinder rdr_mod rdr_occ loc }
| otherwise
= do { unless (not (isQual rdr_name))
(addErrAt loc (badQualBndrErr rdr_name))
; stage <- getStage
; if isBrackStage stage then
do { uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else
do { this_mod <- getModule
; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } }
\end{code}
%*********************************************************
%* *
Source code occurrences
%* *
%*********************************************************
Looking up a name in the RnEnv.
Note [Type and class operator definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to reject all of these unless we have -XTypeOperators (Trac #3265)
data a :*: b = ...
class a :*: b where ...
data (:*:) a b = ....
class (:*:) a b where ...
The latter two mean that we are not just looking for a
*syntactically-infix* declaration, but one that uses an operator
OccName. We use OccName.isSymOcc to detect that case, which isn't
terribly efficient, but there seems to be no better way.
\begin{code}
lookupTopBndrRn :: RdrName -> RnM Name
lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
case nopt of
Just n' -> return n'
Nothing -> do traceRn $ text "lookupTopBndrRn"
unboundName WL_LocalTop n
lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
lookupTopBndrRn_maybe rdr_name
| Just name <- isExact_maybe rdr_name
= do { name' <- lookupExactOcc name; return (Just name') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { loc <- getSrcSpanM
; n <- newGlobalBinder rdr_mod rdr_occ loc
; return (Just n)}
| otherwise
= do {
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- xoptM Opt_TypeOperators
; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn rdr_name
; case mb_gre of
Nothing -> return Nothing
Just gre -> return (Just $ gre_name gre) }
lookupExactOcc :: Name -> RnM Name
lookupExactOcc name
| isExternalName name = return name
| otherwise = do { env <- getGlobalRdrEnv
; let gres = lookupGRE_Name env name
; case gres of
[] -> return name
[gre] -> return (gre_name gre)
_ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) }
lookupInstDeclBndr :: Name -> RdrName -> RnM Name
lookupInstDeclBndr cls rdr
= do { when (isQual rdr)
(addErr (badQualBndrErr rdr))
; lookupSubBndr (ParentIs cls) doc rdr }
where
doc = ptext (sLit "method of class") <+> quotes (ppr cls)
lookupConstructorFields :: Name -> RnM [Name]
lookupConstructorFields con_name
= do { this_mod <- getModule
; if nameIsLocalOrFrom this_mod con_name then
do { RecFields field_env _ <- getRecFieldEnv
; return (lookupNameEnv field_env con_name `orElse` []) }
else
do { con <- tcLookupDataCon con_name
; return (dataConFieldLabels con) } }
lookupSubBndr :: Parent
-> SDoc -> RdrName
-> RnM Name
lookupSubBndr parent doc rdr_name
| Just n <- isExact_maybe rdr_name
= lookupExactOcc n
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= lookupOrig rdr_mod rdr_occ
| otherwise
= do {
env <- getGlobalRdrEnv
; case lookupSubBndrGREs env parent rdr_name of
[gre] -> do { addUsedRdrName gre (used_rdr_name gre)
; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name)
; return (mkUnboundName rdr_name) }
gres -> do { addNameClashErrRn rdr_name gres
; return (gre_name (head gres)) } }
where
used_rdr_name gre
| isQual rdr_name = rdr_name
| otherwise = case gre_prov gre of
LocalDef -> rdr_name
Imported is -> used_rdr_name_from_is is
used_rdr_name_from_is imp_specs
| not (all (is_qual . is_decl) imp_specs)
= rdr_name
| otherwise
=
ASSERT( not (null imp_specs) )
mkRdrQual (is_as (is_decl (head imp_specs))) (rdrNameOcc rdr_name)
lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt]
lookupSubBndrGREs env parent rdr_name
= case parent of
NoParent -> pickGREs rdr_name gres
ParentIs p
| isUnqual rdr_name -> filter (parent_is p) gres
| otherwise -> filter (parent_is p) (pickGREs rdr_name gres)
where
gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
parent_is p (GRE { gre_par = ParentIs p' }) = p == p'
parent_is _ _ = False
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
\end{code}
Note [Usage for sub-bndrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have this
import qualified M( C( f ) )
instance M.C T where
f x = x
then is the qualified import M.f used? Obviously yes.
But the RdrName used in the instance decl is unqualified. In effect,
we fill in the qualification by looking for f's whose class is M.C
But when adding to the UsedRdrNames we must make that qualification
explicit (saying "used M.f"), otherwise we get "Redundant import of M.f".
So we make up a suitable (fake) RdrName. But be careful
import qualifed M
import M( C(f) )
instance C T where
f x = x
Here we want to record a use of 'f', not of 'M.f', otherwise
we'll miss the fact that the qualified import is redundant.
--------------------------------------------------
-- Occurrences
--------------------------------------------------
\begin{code}
getLookupOccRn :: RnM (Name -> Maybe Name)
getLookupOccRn
= getLocalRdrEnv `thenM` \ local_env ->
return (lookupLocalRdrOcc local_env . nameOccName)
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
lookupLocatedOccRn = wrapLocM lookupOccRn
lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just name -> return name ;
Nothing -> do
{ mb_name <- lookupGlobalOccRn_maybe rdr_name
; case mb_name of {
Just n -> return n ;
Nothing -> do
{
allow_qual <- doptM Opt_ImplicitImportQualified
; is_ghci <- getIsGHCi
; if isQual rdr_name && allow_qual && is_ghci
then lookupQualifiedName rdr_name
else unboundName WL_Any rdr_name } } } } }
lookupGlobalOccRn :: RdrName -> RnM Name
lookupGlobalOccRn rdr_name
= do { mb_name <- lookupGlobalOccRn_maybe rdr_name
; case mb_name of
Just n -> return n
Nothing -> unboundName WL_Global rdr_name }
lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
lookupGlobalOccRn_maybe rdr_name
| Just n <- isExact_maybe rdr_name
= do { n' <- lookupExactOcc n; return (Just n') }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { n <- lookupOrig rdr_mod rdr_occ
; return (Just n) }
| otherwise
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of
Nothing -> return Nothing
Just gre -> return (Just (gre_name gre)) }
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreRn_maybe rdr_name
= lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
lookupGreRn :: RdrName -> RnM GlobalRdrElt
lookupGreRn rdr_name
= do { mb_gre <- lookupGreRn_maybe rdr_name
; case mb_gre of {
Just gre -> return gre ;
Nothing -> do
{ name <- unboundName WL_Global rdr_name
; return (GRE { gre_name = name, gre_par = NoParent,
gre_prov = LocalDef }) }}}
lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt)
lookupGreLocalRn rdr_name
= lookupGreRn_help rdr_name lookup_fn
where
lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env)
lookupGreRn_help :: RdrName
-> (GlobalRdrEnv -> [GlobalRdrElt])
-> RnM (Maybe GlobalRdrElt)
lookupGreRn_help rdr_name lookup
= do { env <- getGlobalRdrEnv
; case lookup env of
[] -> return Nothing
[gre] -> do { addUsedRdrName gre rdr_name
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres
; return (Just (head gres)) } }
addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
addUsedRdrName gre rdr
| isLocalGRE gre = return ()
| otherwise = do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
(\s -> Set.insert rdr s) }
addUsedRdrNames :: [RdrName] -> RnM ()
addUsedRdrNames rdrs
= do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
(\s -> foldr Set.insert s rdrs) }
lookupQualifiedName :: RdrName -> RnM Name
lookupQualifiedName rdr_name
| Just (mod,occ) <- isQual_maybe rdr_name
= loadSrcInterface doc mod False Nothing `thenM` \ iface ->
case [ name
| avail <- mi_exports iface,
name <- availNames avail,
nameOccName name == occ ] of
(n:ns) -> ASSERT (null ns) return n
_ -> unboundName WL_Any rdr_name
| otherwise
= pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
where
doc = ptext (sLit "Need to find") <+> ppr rdr_name
\end{code}
Note [Looking up signature names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
lookupSigOccRn is used for type signatures and pragmas
Is this valid?
module A
import M( f )
f :: Int -> Int
f x = x
It's clear that the 'f' in the signature must refer to A.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
However, consider this case:
import M( f )
f :: Int -> Int
g x = x
We don't want to say 'f' is out of scope; instead, we want to
return the imported 'f', so that later on the reanamer will
correctly report "misplaced type sig".
\begin{code}
lookupSigOccRn :: Maybe NameSet
-> Sig RdrName
-> Located RdrName -> RnM (Located Name)
lookupSigOccRn mb_bound_names sig
= wrapLocM $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc mb_bound_names (hsSigDoc sig) rdr_name
; case mb_name of
Left err -> do { addErr err; return (mkUnboundName rdr_name) }
Right name -> return name }
lookupBindGroupOcc :: Maybe NameSet
-> SDoc
-> RdrName -> RnM (Either Message Name)
lookupBindGroupOcc mb_bound_names what rdr_name
= do { local_env <- getLocalRdrEnv
; case lookupLocalRdrEnv local_env rdr_name of {
Just n -> check_local_name n;
Nothing -> do
{ env <- getGlobalRdrEnv
; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
; case (filter isLocalGRE gres) of
(gre:_) -> check_local_name (gre_name gre)
[] | null gres -> bale_out_with empty
| otherwise -> bale_out_with import_msg
}}}
where
check_local_name name
= case mb_bound_names of
Just bound_names | not (name `elemNameSet` bound_names)
-> bale_out_with local_msg
_other -> return (Right name)
bale_out_with msg
= return (Left (sep [ ptext (sLit "The") <+> what
<+> ptext (sLit "for") <+> quotes (ppr rdr_name)
, nest 2 $ ptext (sLit "lacks an accompanying binding")]
$$ nest 2 msg))
local_msg = parens $ ptext (sLit "The") <+> what <+> ptext (sLit "must be given where")
<+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
import_msg = parens $ ptext (sLit "You cannot give a") <+> what
<+> ptext (sLit "for an imported value")
lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
lookupLocalDataTcNames bound_names what rdr_name
| Just n <- isExact_maybe rdr_name
= do { n' <- lookupExactOcc n; return [n'] }
| otherwise
= do { mb_gres <- mapM (lookupBindGroupOcc (Just bound_names) what)
(dataTcOccs rdr_name)
; let (errs, names) = splitEithers mb_gres
; when (null names) (addErr (head errs))
; return names }
dataTcOccs :: RdrName -> [RdrName]
dataTcOccs rdr_name
| Just n <- isExact_maybe rdr_name
, n `hasKey` consDataConKey = [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}
%*********************************************************
%* *
Fixities
%* *
%*********************************************************
\begin{code}
type FastStringEnv a = UniqFM a
emptyFsEnv :: FastStringEnv a
lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
emptyFsEnv = emptyUFM
lookupFsEnv = lookupUFM
extendFsEnv = addToUFM
type MiniFixityEnv = FastStringEnv (Located Fixity)
addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
addLocalFixities mini_fix_env names thing_inside
= extendFixityEnv (mapCatMaybes find_fixity names) thing_inside
where
find_fixity name
= case lookupFsEnv mini_fix_env (occNameFS occ) of
Just (L _ fix) -> Just (name, FixItem occ fix)
Nothing -> Nothing
where
occ = nameOccName name
\end{code}
--------------------------------
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}
lookupFixityRn :: Name -> RnM Fixity
lookupFixityRn name
= getModule `thenM` \ this_mod ->
if nameIsLocalOrFrom this_mod name
then do
local_fix_env <- getFixityEnv
traceRn (text "lookupFixityRn: looking up name in local environment:" <+>
vcat [ppr name, ppr local_fix_env])
return $ lookupFixity local_fix_env name
else
loadInterfaceForName doc name `thenM` \ iface -> do {
traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]);
return (mi_fix_fn iface (nameOccName name))
}
where
doc = ptext (sLit "Checking fixity for") <+> ppr name
lookupTyFixityRn :: Located Name -> RnM Fixity
lookupTyFixityRn (L _ n) = lookupFixityRn n
\end{code}
%************************************************************************
%* *
Rebindable names
Dealing with rebindable syntax is driven by the
Opt_RebindableSyntax dynamic flag.
In "deriving" code we don't want to use rebindable syntax
so we switch off the flag locally
%* *
%************************************************************************
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/HsIsString
* NegApp
* NPlusKPat
* 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}
lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
lookupIfThenElse
= do { rebind <- xoptM Opt_RebindableSyntax
; if not rebind
then return (Nothing, emptyFVs)
else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
; return (Just (HsVar ite), unitFV ite) } }
lookupSyntaxName :: Name
-> RnM (SyntaxExpr Name, FreeVars)
lookupSyntaxName std_name
= xoptM Opt_RebindableSyntax `thenM` \ rebindable_on ->
if not rebindable_on then normal_case
else
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
return (HsVar usr_name, unitFV usr_name)
where
normal_case = return (HsVar std_name, emptyFVs)
lookupSyntaxTable :: [Name]
-> RnM (SyntaxTable Name, FreeVars)
lookupSyntaxTable std_names
= xoptM Opt_RebindableSyntax `thenM` \ rebindable_on ->
if not rebindable_on then normal_case
else
mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
return (std_names `zip` map HsVar usr_names, mkFVs usr_names)
where
normal_case = return (std_names `zip` map HsVar std_names, emptyFVs)
\end{code}
%*********************************************************
%* *
\subsection{Binding}
%* *
%*********************************************************
\begin{code}
newLocalBndrRn :: Located RdrName -> RnM Name
newLocalBndrRn (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
= return name
| otherwise
= do { unless (isUnqual rdr_name)
(addErrAt loc (badQualBndrErr rdr_name))
; uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
bindLocatedLocalsRn :: [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
= do { checkDupAndShadowedRdrNames rdr_names_w_loc
; names <- newLocalBndrsRn rdr_names_w_loc
; bindLocalNames names (enclosed_scope names) }
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= do { name_env <- getLocalRdrEnv
; setLocalRdrEnv (extendLocalRdrEnvList name_env names)
enclosed_scope }
bindLocalName :: Name -> RnM a -> RnM a
bindLocalName name enclosed_scope
= do { name_env <- getLocalRdrEnv
; setLocalRdrEnv (extendLocalRdrEnv name_env name)
enclosed_scope }
bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV names enclosed_scope
= do { (result, fvs) <- bindLocalNames names enclosed_scope
; return (result, delFVs names fvs) }
bindLocatedLocalsFV :: [Located RdrName]
-> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
bindLocatedLocalsFV rdr_names enclosed_scope
= bindLocatedLocalsRn rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) ->
return (thing, delFVs names fvs)
bindTyVarsFV :: [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindTyVarsFV tyvars thing_inside
= bindTyVarsRn tyvars $ \ tyvars' ->
do { (res, fvs) <- thing_inside tyvars'
; return (res, delFVs (map hsLTyVarName tyvars') fvs) }
bindTyVarsRn :: [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM a)
-> RnM a
bindTyVarsRn tyvar_names enclosed_scope
= bindLocatedLocalsRn located_tyvars $ \ names ->
do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
where
replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
located_tyvars = hsLTyVarLocNames tyvar_names
kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names]
bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
bindPatSigTyVars tys thing_inside
= do { scoped_tyvars <- xoptM 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
; bindLocatedLocalsRn nubbed_tvs thing_inside }}
bindPatSigTyVarsFV :: [LHsType RdrName]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindPatSigTyVarsFV tys thing_inside
= bindPatSigTyVars tys $ \ tvs ->
thing_inside `thenM` \ (result,fvs) ->
return (result, fvs `delListFromNameSet` tvs)
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindSigTyVarsFV tvs thing_inside
= do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
; if not scoped_tyvars then
thing_inside
else
bindLocalNamesFV tvs thing_inside }
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
checkDupRdrNames :: [Located RdrName] -> RnM ()
checkDupRdrNames rdr_names_w_loc
= mapM_ (dupNamesErr getLoc) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
checkDupNames :: [Name] -> RnM ()
checkDupNames names
= mapM_ (dupNamesErr nameSrcSpan) dups
where
(_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) $
filterOut isSystemName names
checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
checkDupAndShadowedRdrNames loc_rdr_names
= do { checkDupRdrNames loc_rdr_names
; envs <- getRdrEnvs
; checkShadowedOccs envs loc_occs }
where
loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames envs names
= do { checkDupNames names
; checkShadowedOccs envs loc_occs }
where
loc_occs = [(nameSrcSpan name, nameOccName name) | name <- names]
checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM ()
checkShadowedOccs (global_env,local_env) loc_occs
= ifWOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr loc_occs)
; mapM_ check_shadow loc_occs }
where
check_shadow (loc, occ)
| startsWithUnderscore occ = return ()
| Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)]
| otherwise = do { gres' <- filterM is_shadowed_gre gres
; complain (map pprNameProvenance gres') }
where
complain [] = return ()
complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs)
mb_local = lookupLocalRdrOcc local_env occ
gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env
is_shadowed_gre :: GlobalRdrElt -> RnM Bool
is_shadowed_gre gre@(GRE { gre_par = ParentIs _ })
= do { dflags <- getDOpts
; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags)
then do { is_fld <- is_rec_fld gre; return (not is_fld) }
else return True }
is_shadowed_gre _other = return True
is_rec_fld gre
| isLocalGRE gre = do { RecFields _ fld_set <- getRecFieldEnv
; return (gre_name gre `elemNameSet` fld_set) }
| otherwise = do { sel_id <- tcLookupField (gre_name gre)
; return (isRecordSelector sel_id) }
\end{code}
%************************************************************************
%* *
What to do when a lookup fails
%* *
%************************************************************************
\begin{code}
data WhereLooking = WL_Any
| WL_Global
| WL_LocalTop
unboundName :: WhereLooking -> RdrName -> RnM Name
unboundName where_look rdr_name
= do { show_helpful_errors <- doptM Opt_HelpfulErrors
; let err = unknownNameErr rdr_name
; if not show_helpful_errors
then addErr err
else do { extra_err <- unknownNameSuggestErr where_look rdr_name
; addErr (err $$ extra_err) }
; env <- getGlobalRdrEnv;
; traceRn (vcat [unknownNameErr rdr_name,
ptext (sLit "Global envt is:"),
nest 3 (pprGlobalRdrEnv env)])
; return (mkUnboundName rdr_name) }
unknownNameErr :: RdrName -> SDoc
unknownNameErr rdr_name
= vcat [ hang (ptext (sLit "Not in scope:"))
2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
<+> quotes (ppr rdr_name))
, extra ]
where
extra | rdr_name == forall_tv_RDR = perhapsForallMsg
| otherwise = empty
type HowInScope = Either SrcSpan ImpDeclSpec
unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc
unknownNameSuggestErr where_look tried_rdr_name
= do { local_env <- getLocalRdrEnv
; global_env <- getGlobalRdrEnv
; let all_possibilities :: [(String, (RdrName, HowInScope))]
all_possibilities
= [ (showSDoc (ppr r), (r, Left loc))
| (r,loc) <- local_possibilities local_env ]
++ [ (showSDoc (ppr r), rp) | (r,rp) <- global_possibilities global_env ]
suggest = fuzzyLookup (showSDoc (ppr tried_rdr_name)) all_possibilities
perhaps = ptext (sLit "Perhaps you meant")
extra_err = case suggest of
[] -> empty
[p] -> perhaps <+> pp_item p
ps -> sep [ perhaps <+> ptext (sLit "one of these:")
, nest 2 (pprWithCommas pp_item ps) ]
; return extra_err }
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+>
parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
where loc' = case loc of
UnhelpfulSpan _ ->
panic "unknownNameSuggestErr UnhelpfulSpan"
RealSrcSpan l -> l
pp_item (rdr, Right is) = quotes (ppr rdr) <+>
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
tried_occ = rdrNameOcc tried_rdr_name
tried_is_sym = isSymOcc tried_occ
tried_ns = occNameSpace tried_occ
tried_is_qual = isQual tried_rdr_name
correct_name_space occ = occNameSpace occ == tried_ns
&& isSymOcc occ == tried_is_sym
local_ok = case where_look of { WL_Any -> True; _ -> False }
local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
local_possibilities env
| tried_is_qual = []
| not local_ok = []
| otherwise = [ (mkRdrUnqual occ, nameSrcSpan name)
| name <- occEnvElts env
, let occ = nameOccName name
, correct_name_space occ]
gre_ok :: GlobalRdrElt -> Bool
gre_ok = case where_look of
WL_LocalTop -> isLocalGRE
_ -> \_ -> True
global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
global_possibilities global_env
| tried_is_qual = [ (rdr_qual, (rdr_qual, how))
| gre <- globalRdrEnvElts global_env
, gre_ok gre
, let name = gre_name gre
occ = nameOccName name
, correct_name_space occ
, (mod, how) <- quals_in_scope name (gre_prov gre)
, let rdr_qual = mkRdrQual mod occ ]
| otherwise = [ (rdr_unqual, pair)
| gre <- globalRdrEnvElts global_env
, gre_ok gre
, let name = gre_name gre
prov = gre_prov gre
occ = nameOccName name
rdr_unqual = mkRdrUnqual occ
, correct_name_space occ
, pair <- case (unquals_in_scope name prov, quals_only occ prov) of
(how:_, _) -> [ (rdr_unqual, how) ]
([], pr:_) -> [ pr ]
([], []) -> [] ]
unquals_in_scope :: Name -> Provenance -> [HowInScope]
unquals_in_scope n LocalDef = [ Left (nameSrcSpan n) ]
unquals_in_scope _ (Imported is) = [ Right ispec
| i <- is, let ispec = is_decl i
, not (is_qual ispec) ]
quals_in_scope :: Name -> Provenance -> [(ModuleName, HowInScope)]
quals_in_scope n LocalDef = case nameModule_maybe n of
Nothing -> []
Just m -> [(moduleName m, Left (nameSrcSpan n))]
quals_in_scope _ (Imported is) = [ (is_as ispec, Right ispec)
| i <- is, let ispec = is_decl i ]
quals_only :: OccName -> Provenance -> [(RdrName, HowInScope)]
quals_only _ LocalDef = []
quals_only occ (Imported is) = [ (mkRdrQual (is_as ispec) occ, Right ispec)
| i <- is, let ispec = is_decl i, is_qual ispec ]
\end{code}
%************************************************************************
%* *
\subsection{Free variable manipulation}
%* *
%************************************************************************
\begin{code}
addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
; return (res, fvs1 `plusFV` fvs2) }
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
(ys, fvs_s) -> return (ys, plusFVs fvs_s)
mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c)
-> [a] -> ([b] -> RnM c) -> RnM c
mapFvRnCPS _ [] cont = cont []
mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
mapFvRnCPS f xs $ \ xs' ->
cont (x':xs')
\end{code}
%************************************************************************
%* *
\subsection{Envt utility functions}
%* *
%************************************************************************
\begin{code}
warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedTopBinds gres
= ifWOptM Opt_WarnUnusedBinds
$ do isBoot <- tcIsHsBoot
let noParent gre = case gre_par gre of
NoParent -> True
ParentIs _ -> False
gres' = if isBoot then filter noParent gres
else gres
warnUnusedGREs gres'
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches
check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
check_unused flag bound_names used_names
= ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names))
warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
warnUnusedGREs gres
= warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres]
warnUnusedLocals :: [Name] -> RnM ()
warnUnusedLocals names
= warnUnusedBinds [(n,LocalDef) | n<-names]
warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names)
where reportable (name,_)
| isWiredInName name = False
| otherwise = not (startsWithUnderscore (nameOccName name))
warnUnusedName :: (Name, Provenance) -> RnM ()
warnUnusedName (name, LocalDef)
= addUnusedWarning name (nameSrcSpan name)
(ptext (sLit "Defined but not used"))
warnUnusedName (name, Imported is)
= mapM_ warn is
where
warn spec = addUnusedWarning name span msg
where
span = importSpecLoc spec
pp_mod = quotes (ppr (importSpecModule spec))
msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM ()
addUnusedWarning name span msg
= addWarnAt span $
sep [msg <> colon,
nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
<+> quotes (ppr name)]
\end{code}
\begin{code}
addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
addNameClashErrRn rdr_name names
= addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
where
(np1:nps) = names
msg1 = ptext (sLit "either") <+> mk_ref np1
msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps]
mk_ref gre = sep [quotes (ppr (gre_name gre)) <> comma, pprNameProvenance gre]
shadowedNameWarn :: OccName -> [SDoc] -> SDoc
shadowedNameWarn occ shadowed_locs
= sep [ptext (sLit "This binding for") <+> quotes (ppr occ)
<+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs,
nest 2 (vcat shadowed_locs)]
perhapsForallMsg :: SDoc
perhapsForallMsg
= vcat [ ptext (sLit "Perhaps you intended to use -XExplicitForAll or similar flag")
, ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")]
unknownSubordinateErr :: SDoc -> RdrName -> SDoc
unknownSubordinateErr doc op
= quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc
badOrigBinding :: RdrName -> SDoc
badOrigBinding name
= ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
dupNamesErr get_loc names
= addErrAt big_loc $
vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)),
locations]
where
locs = map get_loc names
big_loc = foldr1 combineSrcSpans locs
locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs))
kindSigErr :: Outputable a => a -> SDoc
kindSigErr thing
= hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
2 (ptext (sLit "Perhaps you intended to use -XKindSignatures"))
badQualBndrErr :: RdrName -> SDoc
badQualBndrErr rdr_name
= ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name
opDeclErr :: RdrName -> SDoc
opDeclErr n
= hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n))
2 (ptext (sLit "Use -XTypeOperators to declare operators in type and declarations"))
\end{code}