Commit d64022dc authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Improvements to record puns, wildcards

* Make C { A.a } work with punning, expanding to C { A.a = a }

* Make it so that, with -fwarn-unused-matches, 
        f (C {..}) = x
  does not complain about the bindings introduced by the "..".

* Make -XRecordWildCards implies -XDisambiguateRecordFields.

* Overall refactoring of RnPat, which had become very crufty. 
  In particular, there is now a monad, CpsRn, private to RnPat,
  which deals with the cps-style plumbing.  This is why so many
  lines of RnPat have changed.

* Refactor the treatment of renaming of record fields into two passes
	- rnHsRecFields1, used both for patterns and expressions,
	     which expands puns, wild-cards
  	- a local renamer in RnPat for fields in patterns
	- a local renamer in RnExpr for fields in construction and update
  This make it all MUCH easier to understand
 
* Improve documentation of record puns, wildcards, and disambiguation
parent 4a84e214
...@@ -40,7 +40,7 @@ module RdrName ( ...@@ -40,7 +40,7 @@ module RdrName (
showRdrName, showRdrName,
-- * Local mapping of 'RdrName' to 'Name.Name' -- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv,
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's -- * Global mapping of 'RdrName' to 'GlobalRdrElt's
...@@ -48,7 +48,7 @@ module RdrName ( ...@@ -48,7 +48,7 @@ module RdrName (
lookupGlobalRdrEnv, extendGlobalRdrEnv, lookupGlobalRdrEnv, extendGlobalRdrEnv,
pprGlobalRdrEnv, globalRdrEnvElts, pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes, lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
hideSomeUnquals, findLocalDupsRdrEnv, hideSomeUnquals, findLocalDupsRdrEnv, pickGREs,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK, GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
...@@ -316,8 +316,12 @@ type LocalRdrEnv = OccEnv Name ...@@ -316,8 +316,12 @@ type LocalRdrEnv = OccEnv Name
emptyLocalRdrEnv :: LocalRdrEnv emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = emptyOccEnv emptyLocalRdrEnv = emptyOccEnv
extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv env names extendLocalRdrEnv env name
= extendOccEnv env (nameOccName name) name
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList env names
= extendOccEnvList env [(nameOccName n, n) | n <- names] = extendOccEnvList env [(nameOccName n, n) | n <- names]
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
...@@ -474,7 +478,7 @@ pickGREs rdr_name gres ...@@ -474,7 +478,7 @@ pickGREs rdr_name gres
pick :: GlobalRdrElt -> Maybe GlobalRdrElt pick :: GlobalRdrElt -> Maybe GlobalRdrElt
pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def
| rdr_is_unqual = Just gre | rdr_is_unqual = Just gre
| Just (mod,_) <- rdr_is_qual -- Qualified name | Just (mod,_) <- rdr_is_qual -- Qualified name
, Just n_mod <- nameModule_maybe n -- Binder is External , Just n_mod <- nameModule_maybe n -- Binder is External
, mod == moduleName n_mod = Just gre , mod == moduleName n_mod = Just gre
| otherwise = Nothing | otherwise = Nothing
......
...@@ -1856,6 +1856,12 @@ impliedFlags ...@@ -1856,6 +1856,12 @@ impliedFlags
, (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see
-- Note [Scoped tyvars] in TcBinds -- Note [Scoped tyvars] in TcBinds
, (Opt_ImpredicativeTypes, Opt_RankNTypes) , (Opt_ImpredicativeTypes, Opt_RankNTypes)
-- Record wild-cards implies field disambiguation
-- Otherwise if you write (C {..}) you may well get
-- stuff like " 'a' not in scope ", which is a bit silly
-- if the compiler has just filled in field 'a' of constructor 'C'
, (Opt_RecordWildCards, Opt_DisambiguateRecordFields)
] ]
glasgowExtsFlags :: [DynFlag] glasgowExtsFlags :: [DynFlag]
......
...@@ -53,8 +53,7 @@ import HsSyn -- Lots of it ...@@ -53,8 +53,7 @@ import HsSyn -- Lots of it
import Class ( FunDep ) import Class ( FunDep )
import TypeRep ( Kind ) import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
setRdrNameSpace, showRdrName )
import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
InlinePragma(..), InlineSpec(..), InlinePragma(..), InlineSpec(..),
alwaysInlineSpec, neverInlineSpec ) alwaysInlineSpec, neverInlineSpec )
...@@ -728,11 +727,9 @@ checkPat loc _ _ ...@@ -728,11 +727,9 @@ checkPat loc _ _
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName) checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of checkAPat dynflags loc e = case e of
EWildPat -> return (WildPat placeHolderType) EWildPat -> return (WildPat placeHolderType)
HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " HsVar x -> return (VarPat x)
++ showRdrName x) HsLit l -> return (LitPat l)
| otherwise -> return (VarPat x)
HsLit l -> return (LitPat l)
-- Overloaded numeric patterns (e.g. f 0 x = x) -- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve -- Negation is recorded separately, so that the literal is zero or +ve
...@@ -831,10 +828,6 @@ checkFunBind :: SrcSpan ...@@ -831,10 +828,6 @@ checkFunBind :: SrcSpan
-> Located (GRHSs RdrName) -> Located (GRHSs RdrName)
-> P (HsBind RdrName) -> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss) checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
| isQual (unLoc fun)
= parseErrorSDoc (getLoc fun)
(ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
| otherwise
= do ps <- checkPatterns pats = do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span let match_span = combineSrcSpans lhs_loc rhs_span
return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)]) return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
......
...@@ -23,7 +23,7 @@ import RdrHsSyn ...@@ -23,7 +23,7 @@ import RdrHsSyn
import RnHsSyn import RnHsSyn
import TcRnMonad import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, import RnPat (rnPats, rnBindPat,
NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
) )
...@@ -157,8 +157,10 @@ it expects the global environment to contain bindings for the binders ...@@ -157,8 +157,10 @@ it expects the global environment to contain bindings for the binders
rnTopBindsLHS :: MiniFixityEnv rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName -> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName) -> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds = rnTopBindsLHS fix_env binds
(uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds = do { let (boundNames,doc) = bindersAndDoc binds
; mod <- getModule
; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) boundNames doc binds }
rnTopBindsRHS :: NameSet -- Names bound by these binds rnTopBindsRHS :: NameSet -- Names bound by these binds
-> HsValBindsLR Name RdrName -> HsValBindsLR Name RdrName
...@@ -461,8 +463,7 @@ rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), ...@@ -461,8 +463,7 @@ rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _),
fun_tick = fun_tick fun_tick = fun_tick
})) }))
= setSrcSpan loc $ = setSrcSpan loc $
do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname -> do { newname <- applyNameMaker name_maker name
return (newname, emptyFVs)
; return (L loc (FunBind { fun_id = L nameLoc newname, ; return (L loc (FunBind { fun_id = L nameLoc newname,
fun_infix = inf, fun_infix = inf,
fun_matches = matches, fun_matches = matches,
...@@ -769,7 +770,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) ...@@ -769,7 +770,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
-- Now the main event -- Now the main event
-- note that there are no local ficity decls for matches -- note that there are no local ficity decls for matches
; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do ; rnPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt grhss { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
; return (Match pats' Nothing grhss', grhss_fvs) }} ; return (Match pats' Nothing grhss', grhss_fvs) }}
......
...@@ -12,13 +12,13 @@ module RnEnv ( ...@@ -12,13 +12,13 @@ module RnEnv (
lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn, lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn, lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupInstDeclBndr, lookupLocatedSubBndr, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupSyntaxName, lookupSyntaxTable,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames, getLookupOccRn, addUsedRdrNames,
newLocalsRn, newIPNameRn, newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV, bindLocalName, bindLocalNames, bindLocalNamesFV,
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
bindLocalNamesFV_WithFixities, bindLocalNamesFV_WithFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn, bindLocatedLocalsFV, bindLocatedLocalsRn,
...@@ -30,9 +30,7 @@ module RnEnv ( ...@@ -30,9 +30,7 @@ module RnEnv (
mapFvRn, mapFvRnCPS, mapFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds, warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg, dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
checkM
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -55,8 +53,8 @@ import DataCon ( dataConFieldLabels ) ...@@ -55,8 +53,8 @@ import DataCon ( dataConFieldLabels )
import OccName import OccName
import Module ( Module, ModuleName ) import Module ( Module, ModuleName )
import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE,
consDataConKey, hasKey, forall_tv_RDR ) consDataConKey, forall_tv_RDR )
import UniqSupply import Unique
import BasicTypes import BasicTypes
import ErrUtils ( Message ) import ErrUtils ( Message )
import SrcLoc import SrcLoc
...@@ -75,21 +73,6 @@ import qualified Data.Set as Set ...@@ -75,21 +73,6 @@ import qualified Data.Set as Set
-- XXX -- XXX
thenM :: Monad a => a b -> (b -> a c) -> a c thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=) thenM = (>>=)
thenM_ :: Monad a => a b -> a c -> a c
thenM_ = (>>)
returnM :: Monad m => a -> m a
returnM = return
mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
mappM = mapM
mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
mappM_ = mapM_
checkM :: Monad m => Bool -> m () -> m ()
checkM = unless
\end{code} \end{code}
%********************************************************* %*********************************************************
...@@ -112,13 +95,13 @@ newTopSrcBinder this_mod (L loc rdr_name) ...@@ -112,13 +95,13 @@ newTopSrcBinder this_mod (L loc rdr_name)
-- data T = (,) Int Int -- data T = (,) Int Int
-- unless we are in GHC.Tup -- unless we are in GHC.Tup
ASSERT2( isExternalName name, ppr name ) ASSERT2( isExternalName name, ppr name )
do { checkM (this_mod == nameModule name) do { unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name)) (addErrAt loc (badOrigBinding rdr_name))
; return name } ; return name }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) = do { unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(addErrAt loc (badOrigBinding rdr_name)) (addErrAt loc (badOrigBinding rdr_name))
-- When reading External Core we get Orig names as binders, -- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad -- but they should agree with the module gotten from the monad
...@@ -141,7 +124,7 @@ newTopSrcBinder this_mod (L loc rdr_name) ...@@ -141,7 +124,7 @@ newTopSrcBinder this_mod (L loc rdr_name)
--TODO, should pass the whole span --TODO, should pass the whole span
| otherwise | otherwise
= do { checkM (not (isQual rdr_name)) = do { unless (not (isQual rdr_name))
(addErrAt loc (badQualBndrErr rdr_name)) (addErrAt loc (badQualBndrErr rdr_name))
-- Binders should not be qualified; if they are, and with a different -- Binders should not be qualified; if they are, and with a different
-- module name, we we get a confusing "M.T is not in scope" error later -- module name, we we get a confusing "M.T is not in scope" error later
...@@ -207,7 +190,7 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) ...@@ -207,7 +190,7 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
lookupTopBndrRn_maybe rdr_name lookupTopBndrRn_maybe rdr_name
| Just name <- isExact_maybe rdr_name | Just name <- isExact_maybe rdr_name
= returnM (Just name) = return (Just name)
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-- This deals with the case of derived bindings, where -- This deals with the case of derived bindings, where
...@@ -223,12 +206,12 @@ lookupTopBndrRn_maybe rdr_name ...@@ -223,12 +206,12 @@ lookupTopBndrRn_maybe rdr_name
let occ = rdrNameOcc rdr_name let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ) ; when (isTcOcc occ && isSymOcc occ)
(do { op_ok <- doptM Opt_TypeOperators (do { op_ok <- doptM Opt_TypeOperators
; checkM op_ok (addErr (opDeclErr rdr_name)) }) ; unless op_ok (addErr (opDeclErr rdr_name)) })
; mb_gre <- lookupGreLocalRn rdr_name ; mb_gre <- lookupGreLocalRn rdr_name
; case mb_gre of ; case mb_gre of
Nothing -> returnM Nothing Nothing -> return Nothing
Just gre -> returnM (Just $ gre_name gre) } Just gre -> return (Just $ gre_name gre) }
----------------------------------------------- -----------------------------------------------
...@@ -244,40 +227,11 @@ lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) ...@@ -244,40 +227,11 @@ lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
-- name is only in scope qualified. I.e. even if method op is -- name is only in scope qualified. I.e. even if method op is
-- in scope as M.op, we still allow plain 'op' on the LHS of -- in scope as M.op, we still allow plain 'op' on the LHS of
-- an instance decl -- an instance decl
lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr lookupInstDeclBndr cls rdr = lookupLocatedSubBndr (ParentIs cls) doc rdr
where where
doc = ptext (sLit "method of class") <+> quotes (ppr cls) doc = ptext (sLit "method of class") <+> quotes (ppr cls)
is_op (GRE {gre_par = ParentIs n}) = n == cls
is_op _ = False
----------------------------------------------- -----------------------------------------------
lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name)
-- Used for record construction and pattern matching
-- When the -XDisambiguateRecordFields flag is on, take account of the
-- constructor name to disambiguate which field to use; it's just the
-- same as for instance decls
--
-- NB: Consider this:
-- module Foo where { data R = R { fld :: Int } }
-- module Odd where { import Foo; fld x = x { fld = 3 } }
-- Arguably this should work, because the reference to 'fld' is
-- unambiguous because there is only one field id 'fld' in scope.
-- But currently it's rejected.
lookupRecordBndr Nothing rdr_name
= lookupLocatedGlobalOccRn rdr_name
lookupRecordBndr (Just (L _ data_con)) rdr_name
= do { flag_on <- doptM Opt_DisambiguateRecordFields
; if not flag_on
then lookupLocatedGlobalOccRn rdr_name
else do {
fields <- lookupConstructorFields data_con
; let is_field gre = gre_name gre `elem` fields
; lookup_located_sub_bndr is_field doc rdr_name
}}
where
doc = ptext (sLit "field of constructor") <+> quotes (ppr data_con)
lookupConstructorFields :: Name -> RnM [Name] lookupConstructorFields :: Name -> RnM [Name]
-- Look up the fields of a given constructor -- Look up the fields of a given constructor
-- * For constructors from this module, use the record field env, -- * For constructors from this module, use the record field env,
...@@ -298,34 +252,57 @@ lookupConstructorFields con_name ...@@ -298,34 +252,57 @@ lookupConstructorFields con_name
; return (dataConFieldLabels con) } } ; return (dataConFieldLabels con) } }
----------------------------------------------- -----------------------------------------------
lookup_located_sub_bndr :: (GlobalRdrElt -> Bool) -- Used for record construction and pattern matching
-- When the -XDisambiguateRecordFields flag is on, take account of the
-- constructor name to disambiguate which field to use; it's just the
-- same as for instance decls
--
-- NB: Consider this:
-- module Foo where { data R = R { fld :: Int } }
-- module Odd where { import Foo; fld x = x { fld = 3 } }
-- Arguably this should work, because the reference to 'fld' is
-- unambiguous because there is only one field id 'fld' in scope.
-- But currently it's rejected.
lookupLocatedSubBndr :: Parent -- NoParent => just look it up as usual
-- ParentIs p => use p to disambiguate
-> SDoc -> Located RdrName -> SDoc -> Located RdrName
-> RnM (Located Name) -> RnM (Located Name)
lookup_located_sub_bndr is_good doc rdr_name lookupLocatedSubBndr parent doc rdr_name
= wrapLocM (lookup_sub_bndr is_good doc) rdr_name = wrapLocM (lookup_sub_bndr parent doc) rdr_name
lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM Name lookup_sub_bndr :: Parent -> SDoc -> RdrName -> RnM Name
lookup_sub_bndr is_good doc rdr_name lookup_sub_bndr parent doc rdr_name
| isUnqual rdr_name -- Find all the things the rdr-name maps to | Just n <- isExact_maybe rdr_name -- This happens in derived code
= do { -- and pick the one with the right parent name = return n
; addUsedRdrName rdr_name
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= lookupOrig rdr_mod rdr_occ
| otherwise -- Find all the things the rdr-name maps to
= do { -- and pick the one with the right parent name
; env <- getGlobalRdrEnv ; env <- getGlobalRdrEnv
; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) of ; let gres = (lookupGlobalRdrEnv env (rdrNameOcc rdr_name))
; case pick parent gres of
-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
-- The latter does pickGREs, but we want to allow 'x' -- The latter does pickGREs, but we want to allow 'x'
-- even if only 'M.x' is in scope -- even if only 'M.x' is in scope
[gre] -> return (gre_name gre) [gre] -> do { addUsedRdrName gre rdr_name
; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name) [] -> do { addErr (unknownSubordinateErr doc rdr_name)
; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name) ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
; return (mkUnboundName rdr_name) } ; return (mkUnboundName rdr_name) }
gres -> do { addNameClashErrRn rdr_name gres gres -> do { addNameClashErrRn rdr_name gres
; return (gre_name (head gres)) } ; return (gre_name (head gres)) } }
} where
pick NoParent gres -- Normal lookup
= pickGREs rdr_name gres
pick (ParentIs p) gres -- Disambiguating lookup
| isUnqual rdr_name = filter (right_parent p) gres
| otherwise = filter (right_parent p) (pickGREs rdr_name gres)
| otherwise -- Occurs in derived instances, where we just right_parent p (GRE { gre_par = ParentIs p' }) = p==p'
-- refer directly to the right method with an Orig right_parent _ _ = False
-- And record fields can be Quals: C { F.f = x }
= lookupGlobalOccRn rdr_name
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
...@@ -360,7 +337,7 @@ lookupOccRn :: RdrName -> RnM Name ...@@ -360,7 +337,7 @@ lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name lookupOccRn rdr_name
= getLocalRdrEnv `thenM` \ local_env -> = getLocalRdrEnv `thenM` \ local_env ->
case lookupLocalRdrEnv local_env rdr_name of case lookupLocalRdrEnv local_env rdr_name of
Just name -> returnM name Just name -> return name
Nothing -> lookupGlobalOccRn rdr_name Nothing -> lookupGlobalOccRn rdr_name
lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name)
...@@ -413,7 +390,7 @@ unboundName rdr_name ...@@ -413,7 +390,7 @@ unboundName rdr_name
; traceRn (vcat [unknownNameErr rdr_name, ; traceRn (vcat [unknownNameErr rdr_name,
ptext (sLit "Global envt is:"), ptext (sLit "Global envt is:"),
nest 3 (pprGlobalRdrEnv env)]) nest 3 (pprGlobalRdrEnv env)])
; returnM (mkUnboundName rdr_name) } ; return (mkUnboundName rdr_name) }
-------------------------------------------------- --------------------------------------------------
-- Lookup in the Global RdrEnv of the module -- Lookup in the Global RdrEnv of the module
...@@ -422,27 +399,7 @@ unboundName rdr_name ...@@ -422,27 +399,7 @@ unboundName rdr_name
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Just look up the RdrName in the GlobalRdrEnv -- Just look up the RdrName in the GlobalRdrEnv
lookupGreRn_maybe rdr_name lookupGreRn_maybe rdr_name
= do { mGre <- lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
; case mGre of
Just gre ->
case gre_prov gre of
LocalDef -> return ()
Imported _ -> addUsedRdrName rdr_name
Nothing ->
return ()
; return mGre }
addUsedRdrName :: RdrName -> RnM ()
addUsedRdrName rdr
= 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) }
lookupGreRn :: RdrName -> RnM GlobalRdrElt lookupGreRn :: RdrName -> RnM GlobalRdrElt
-- If not found, add error message, and return a fake GRE -- If not found, add error message, and return a fake GRE
...@@ -471,10 +428,28 @@ lookupGreRn_help :: RdrName -- Only used in error message ...@@ -471,10 +428,28 @@ lookupGreRn_help :: RdrName -- Only used in error message
lookupGreRn_help rdr_name lookup lookupGreRn_help rdr_name lookup
= do { env <- getGlobalRdrEnv = do { env <- getGlobalRdrEnv
; case lookup env of ; case lookup env of
[] -> returnM Nothing [] -> return Nothing
[gre] -> returnM (Just gre) [gre] -> do { addUsedRdrName gre rdr_name
; return (Just gre) }
gres -> do { addNameClashErrRn rdr_name gres gres -> do { addNameClashErrRn rdr_name gres
; returnM (Just (head gres)) } } ; return (Just (head gres)) } }
addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
-- Record usage of imported RdrNames
addUsedRdrName gre rdr
| isLocalGRE gre = return ()
| otherwise = do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
(\s -> Set.insert rdr s) }
addUsedRdrNames :: [RdrName] -> RnM ()
-- Record used sub-binders
-- We don't check for imported-ness here, because it's inconvenient
-- and not stritly necessary.
addUsedRdrNames rdrs
= do { env <- getGblEnv
; updMutVar (tcg_used_rdrnames env)
(\s -> foldr Set.insert s rdrs) }
------------------------------ ------------------------------
-- GHCi support -- GHCi support
...@@ -715,7 +690,7 @@ lookupFixityRn name ...@@ -715,7 +690,7 @@ lookupFixityRn name
loadInterfaceForName doc name `thenM` \ iface -> do { loadInterfaceForName doc name `thenM` \ iface -> do {
traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]);
returnM (mi_fix_fn iface (nameOccName name)) return (mi_fix_fn iface (nameOccName name))
} }
where where
doc = ptext (sLit "Checking fixity for") <+> ppr name doc = ptext (sLit "Checking fixity for") <+> ppr name
...@@ -774,9 +749,9 @@ lookupSyntaxName std_name ...@@ -774,9 +749,9 @@ lookupSyntaxName std_name
else else
-- Get the similarly named thing from the local environment -- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
returnM (HsVar usr_name, unitFV usr_name) return (HsVar usr_name, unitFV usr_name)
where where
normal_case = returnM (HsVar std_name, emptyFVs) normal_case = return (HsVar std_name, emptyFVs)
lookupSyntaxTable :: [Name] -- Standard names lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
...@@ -785,11 +760,11 @@ lookupSyntaxTable std_names ...@@ -785,11 +760,11 @@ lookupSyntaxTable std_names
if implicit_prelude then normal_case if implicit_prelude then normal_case
else else
-- Get the similarly named thing from the local environment -- Get the similarly named thing from the local environment
mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) return (std_names `zip` map HsVar usr_names, mkFVs usr_names)
where where
normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) normal_case = return (std_names `zip` map HsVar std_names, emptyFVs)
\end{code} \end{code}
...@@ -800,18 +775,22 @@ lookupSyntaxTable std_names ...@@ -800,18 +775,22 @@ lookupSyntaxTable std_names
%********************************************************* %*********************************************************
\begin{code} \begin{code}
newLocalsRn :: [Located RdrName] -> RnM [Name] newLocalBndrRn :: Located RdrName -> RnM Name
newLocalsRn rdr_names_w_loc -- Used for non-top-level binders. These should
= newUniqueSupply `thenM` \ us -> -- never be qualified.
returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) newLocalBndrRn (L loc rdr_name)
where | Just name <- isExact_maybe rdr_name
mk (L loc rdr_name) uniq = return name -- This happens in code generated by Template Haskell
| Just name <- isExact_maybe rdr_name = name -- although I'm not sure why. Perhpas it's the call
-- This happens in code generated by Template Haskell -- in RnPat.newName LetMk?
| otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) | otherwise
-- We only bind unqualified names here = do { unless (isUnqual rdr_name)
-- lookupRdrEnv doesn't even attempt to look up a qualified RdrName (addErrAt loc (badQualBndrErr rdr_name))
mkInternalName uniq (rdrNameOcc rdr_name) loc ; uniq <- newUnique
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
--------------------- ---------------------
checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM () checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM ()
...@@ -823,26 +802,32 @@ checkDupAndShadowedRdrNames doc loc_rdr_names ...@@ -823,26 +802,32 @@ checkDupAndShadowedRdrNames doc loc_rdr_names
--------------------- ---------------------
bindLocatedLocalsRn :: SDoc -- Documentation string for error message bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [Located RdrName] -> [Located RdrName]
-> ([Name] -> RnM a) -> ([Name] -> RnM a)
-> RnM a -> RnM a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
= checkDupAndShadowedRdrNames doc_str rdr_names_w_loc `thenM_` = do { checkDupAndShadowedRdrNames doc_str rdr_names_w_loc