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 (
showRdrName,
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv,
-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
......@@ -48,7 +48,7 @@ module RdrName (
lookupGlobalRdrEnv, extendGlobalRdrEnv,
pprGlobalRdrEnv, globalRdrEnvElts,
lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
hideSomeUnquals, findLocalDupsRdrEnv,
hideSomeUnquals, findLocalDupsRdrEnv, pickGREs,
-- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
......@@ -316,8 +316,12 @@ type LocalRdrEnv = OccEnv Name
emptyLocalRdrEnv :: LocalRdrEnv
emptyLocalRdrEnv = emptyOccEnv
extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnv env names
extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
extendLocalRdrEnv env name
= extendOccEnv env (nameOccName name) name
extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList env names
= extendOccEnvList env [(nameOccName n, n) | n <- names]
lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
......@@ -474,7 +478,7 @@ pickGREs rdr_name gres
pick :: GlobalRdrElt -> Maybe GlobalRdrElt
pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def
| 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
, mod == moduleName n_mod = Just gre
| otherwise = Nothing
......
......@@ -1856,6 +1856,12 @@ impliedFlags
, (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see
-- Note [Scoped tyvars] in TcBinds
, (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]
......
......@@ -53,8 +53,7 @@ import HsSyn -- Lots of it
import Class ( FunDep )
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace, showRdrName )
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo,
InlinePragma(..), InlineSpec(..),
alwaysInlineSpec, neverInlineSpec )
......@@ -728,11 +727,9 @@ checkPat loc _ _
checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat dynflags loc e = case e of
EWildPat -> return (WildPat placeHolderType)
HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
++ showRdrName x)
| otherwise -> return (VarPat x)
HsLit l -> return (LitPat l)
EWildPat -> return (WildPat placeHolderType)
HsVar x -> return (VarPat x)
HsLit l -> return (LitPat l)
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
......@@ -831,10 +828,6 @@ checkFunBind :: SrcSpan
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
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
let match_span = combineSrcSpans lhs_loc rhs_span
return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
......
......@@ -23,7 +23,7 @@ import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
import RnPat (rnPats, rnBindPat,
NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
)
......@@ -157,8 +157,10 @@ it expects the global environment to contain bindings for the binders
rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds =
(uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
rnTopBindsLHS fix_env binds
= do { let (boundNames,doc) = bindersAndDoc binds
; mod <- getModule
; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) boundNames doc binds }
rnTopBindsRHS :: NameSet -- Names bound by these binds
-> HsValBindsLR Name RdrName
......@@ -461,8 +463,7 @@ rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _),
fun_tick = fun_tick
}))
= setSrcSpan loc $
do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
return (newname, emptyFVs)
do { newname <- applyNameMaker name_maker name
; return (L loc (FunBind { fun_id = L nameLoc newname,
fun_infix = inf,
fun_matches = matches,
......@@ -769,7 +770,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
-- Now the main event
-- 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
; return (Match pats' Nothing grhss', grhss_fvs) }}
......
......@@ -12,13 +12,13 @@ module RnEnv (
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
lookupInstDeclBndr, lookupLocatedSubBndr, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
getLookupOccRn, addUsedRdrNames,
newLocalsRn, newIPNameRn,
bindLocalNames, bindLocalNamesFV,
newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
bindLocalName, bindLocalNames, bindLocalNamesFV,
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
bindLocalNamesFV_WithFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
......@@ -30,9 +30,7 @@ module RnEnv (
mapFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
checkM
dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
) where
#include "HsVersions.h"
......@@ -55,8 +53,8 @@ import DataCon ( dataConFieldLabels )
import OccName
import Module ( Module, ModuleName )
import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE,
consDataConKey, hasKey, forall_tv_RDR )
import UniqSupply
consDataConKey, forall_tv_RDR )
import Unique
import BasicTypes
import ErrUtils ( Message )
import SrcLoc
......@@ -75,21 +73,6 @@ import qualified Data.Set as Set
-- XXX
thenM :: Monad a => a b -> (b -> a c) -> a c
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}
%*********************************************************
......@@ -112,13 +95,13 @@ newTopSrcBinder this_mod (L loc rdr_name)
-- data T = (,) Int Int
-- unless we are in GHC.Tup
ASSERT2( isExternalName name, ppr name )
do { checkM (this_mod == nameModule name)
do { unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name))
; return 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))
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
......@@ -141,7 +124,7 @@ newTopSrcBinder this_mod (L loc rdr_name)
--TODO, should pass the whole span
| otherwise
= do { checkM (not (isQual rdr_name))
= do { unless (not (isQual rdr_name))
(addErrAt loc (badQualBndrErr rdr_name))
-- 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
......@@ -207,7 +190,7 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
lookupTopBndrRn_maybe rdr_name
| Just name <- isExact_maybe rdr_name
= returnM (Just name)
= return (Just name)
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-- This deals with the case of derived bindings, where
......@@ -223,12 +206,12 @@ lookupTopBndrRn_maybe rdr_name
let occ = rdrNameOcc rdr_name
; when (isTcOcc occ && isSymOcc occ)
(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
; case mb_gre of
Nothing -> returnM Nothing
Just gre -> returnM (Just $ gre_name gre) }
Nothing -> return Nothing
Just gre -> return (Just $ gre_name gre) }
-----------------------------------------------
......@@ -244,40 +227,11 @@ lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
-- 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
-- an instance decl
lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr
lookupInstDeclBndr cls rdr = lookupLocatedSubBndr (ParentIs cls) doc rdr
where
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]
-- Look up the fields of a given constructor
-- * For constructors from this module, use the record field env,
......@@ -298,34 +252,57 @@ lookupConstructorFields con_name
; 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
-> RnM (Located Name)
lookup_located_sub_bndr is_good doc rdr_name
= wrapLocM (lookup_sub_bndr is_good doc) rdr_name
lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM Name
lookup_sub_bndr is_good doc rdr_name
| isUnqual rdr_name -- Find all the things the rdr-name maps to
= do { -- and pick the one with the right parent name
; addUsedRdrName rdr_name
lookupLocatedSubBndr parent doc rdr_name
= wrapLocM (lookup_sub_bndr parent doc) rdr_name
lookup_sub_bndr :: Parent -> SDoc -> RdrName -> RnM Name
lookup_sub_bndr parent doc rdr_name
| Just n <- isExact_maybe rdr_name -- This happens in derived code
= return n
| 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
; 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!
-- The latter does pickGREs, but we want to allow 'x'
-- 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)
; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name)
; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
; return (mkUnboundName rdr_name) }
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
-- refer directly to the right method with an Orig
-- And record fields can be Quals: C { F.f = x }
= lookupGlobalOccRn rdr_name
right_parent p (GRE { gre_par = ParentIs p' }) = p==p'
right_parent _ _ = False
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
......@@ -360,7 +337,7 @@ lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name
= getLocalRdrEnv `thenM` \ local_env ->
case lookupLocalRdrEnv local_env rdr_name of
Just name -> returnM name
Just name -> return name
Nothing -> lookupGlobalOccRn rdr_name
lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name)
......@@ -413,7 +390,7 @@ unboundName rdr_name
; traceRn (vcat [unknownNameErr rdr_name,
ptext (sLit "Global envt is:"),
nest 3 (pprGlobalRdrEnv env)])
; returnM (mkUnboundName rdr_name) }
; return (mkUnboundName rdr_name) }
--------------------------------------------------
-- Lookup in the Global RdrEnv of the module
......@@ -422,27 +399,7 @@ unboundName rdr_name
lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
-- Just look up the RdrName in the GlobalRdrEnv
lookupGreRn_maybe rdr_name
= do { mGre <- 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_help rdr_name (lookupGRE_RdrName rdr_name)
lookupGreRn :: RdrName -> RnM GlobalRdrElt
-- If not found, add error message, and return a fake GRE
......@@ -471,10 +428,28 @@ lookupGreRn_help :: RdrName -- Only used in error message
lookupGreRn_help rdr_name lookup
= do { env <- getGlobalRdrEnv
; case lookup env of
[] -> returnM Nothing
[gre] -> returnM (Just gre)
[] -> return Nothing
[gre] -> do { addUsedRdrName gre rdr_name
; return (Just gre) }
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
......@@ -715,7 +690,7 @@ lookupFixityRn name
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)]);
returnM (mi_fix_fn iface (nameOccName name))
return (mi_fix_fn iface (nameOccName name))
}
where
doc = ptext (sLit "Checking fixity for") <+> ppr name
......@@ -774,9 +749,9 @@ lookupSyntaxName std_name
else
-- Get the similarly named thing from the local environment
lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
returnM (HsVar usr_name, unitFV usr_name)
return (HsVar usr_name, unitFV usr_name)
where
normal_case = returnM (HsVar std_name, emptyFVs)
normal_case = return (HsVar std_name, emptyFVs)
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
......@@ -785,11 +760,11 @@ lookupSyntaxTable std_names
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 ->
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
normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs)
normal_case = return (std_names `zip` map HsVar std_names, emptyFVs)
\end{code}
......@@ -800,18 +775,22 @@ lookupSyntaxTable std_names
%*********************************************************
\begin{code}
newLocalsRn :: [Located RdrName] -> RnM [Name]
newLocalsRn rdr_names_w_loc
= 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) loc
newLocalBndrRn :: Located RdrName -> RnM Name
-- Used for non-top-level binders. These should
-- never be qualified.
newLocalBndrRn (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
= return name -- This happens in code generated by Template Haskell
-- although I'm not sure why. Perhpas it's the call
-- in RnPat.newName LetMk?
| 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
---------------------
checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM ()
......@@ -823,26 +802,32 @@ checkDupAndShadowedRdrNames doc loc_rdr_names
---------------------
bindLocatedLocalsRn :: SDoc -- Documentation string for error message
-> [Located RdrName]
-> [Located RdrName]
-> ([Name] -> RnM a)
-> RnM a
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
-- Make fresh Names and extend the environment
newLocalsRn rdr_names_w_loc `thenM` \names ->
bindLocalNames names (enclosed_scope names)
; names <- newLocalBndrsRn rdr_names_w_loc
; bindLocalNames names (enclosed_scope names) }
bindLocalNames :: [Name] -> RnM a -> RnM a
bindLocalNames names enclosed_scope
= getLocalRdrEnv `thenM` \ name_env ->
setLocalRdrEnv (extendLocalRdrEnv name_env 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
; returnM (result, delListFromNameSet fvs names) }
; return (result, delListFromNameSet fvs names) }
-------------------------------------
......@@ -853,7 +838,7 @@ bindLocatedLocalsFV :: SDoc -> [Located RdrName]
bindLocatedLocalsFV doc rdr_names enclosed_scope
= bindLocatedLocalsRn doc rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
return (thing, delListFromNameSet fvs names)
-------------------------------------
bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
......@@ -863,7 +848,7 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
bindTyVarsRn doc_str tyvar_names enclosed_scope
= bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
do { kind_sigs_ok <- doptM Opt_KindSignatures
; checkM (null kinded_tyvars || kind_sigs_ok)
; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
where
......@@ -898,7 +883,7 @@ bindPatSigTyVarsFV :: [LHsType RdrName]
bindPatSigTyVarsFV tys thing_inside
= bindPatSigTyVars tys $ \ tvs ->
thing_inside `thenM` \ (result,fvs) ->
returnM (result, fvs `delListFromNameSet` tvs)
return (result, fvs `delListFromNameSet` tvs)
bindSigTyVarsFV :: [Name]
-> RnM (a, FreeVars)
......@@ -920,7 +905,7 @@ checkDupRdrNames :: SDoc
-> RnM ()
checkDupRdrNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
mappM_ (dupNamesErr getLoc doc_str) dups
mapM_ (dupNamesErr getLoc doc_str) dups
where
(_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
......@@ -929,7 +914,7 @@ checkDupNames :: SDoc
-> RnM ()
checkDupNames doc_str names
= -- Check for duplicated names in a binding group
mappM_ (dupNamesErr nameSrcSpan doc_str) dups
mapM_ (dupNamesErr nameSrcSpan doc_str) dups
where
(_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
......@@ -938,7 +923,7 @@ checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)]
checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
= ifOptM Opt_WarnNameShadowing $
do { traceRn (text "shadow" <+> ppr loc_rdr_names)
; mappM_ check_shadow loc_rdr_names }
; mapM_ check_shadow loc_rdr_names }
where
check_shadow (loc, occ)
| startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
......@@ -981,9 +966,9 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
\begin{code}
-- A useful utility
mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn f xs = do stuff <- mappM f xs
mapFvRn f xs = do stuff <- mapM f xs
case unzip stuff of
(ys, fvs_s) -> returnM (ys, plusFVs fvs_s)
(ys, fvs_s) -> return (ys, plusFVs fvs_s)
-- because some of the rename functions are CPSed:
-- maps the function across the list from left to right;
......@@ -1007,7 +992,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
\begin{code}
warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
warnUnusedModules mods
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
= ifOptM Opt_WarnUnusedImports (mapM_ bleat mods)
where
bleat (mod,loc) = addWarnAt loc (mk_warn mod)
mk_warn m = vcat [ptext (sLit "Module") <+> quotes (ppr m)
......@@ -1041,7 +1026,7 @@ warnUnusedLocals names
= warnUnusedBinds [(n,LocalDef) | n<-names]
warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names)
warnUnusedBinds names = mapM_ warnUnusedName (filter reportable names)
where reportable (name,_)
| isWiredInName name = False -- Don't report unused wired-in names
-- Otherwise we get a zillion warnings
......
......@@ -48,6 +48,7 @@ import Maybes ( expectJust )
import Outputable
import SrcLoc
import FastString
import Control.Monad
\end{code}
......@@ -248,13 +249,13 @@ rnExpr (ExplicitTuple tup_args boxity)
rnExpr (RecordCon con_id _ rbinds)
= do { conname <- lookupLocatedOccRn con_id
; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
; return (RecordCon conname noPostTcExpr rbinds',
fvRbinds `addOneFV` unLoc conname) }
rnExpr (RecordUpd expr rbinds _ _ _)
= do { (expr', fvExpr) <- rnLExpr expr
; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
; return (RecordUpd expr' rbinds' [] [] [],
fvExpr `plusFV` fvRbinds) }
......@@ -307,7 +308,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
\begin{code}
rnExpr (HsProc pat body)
= newArrowScope $
rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
rnPats ProcExpr [pat] $ \ [pat'] ->
rnCmdTop body `thenM` \ (body',fvBody) ->
return (HsProc pat' body', fvBody)
......@@ -362,6 +363,26 @@ rnSection section@(SectionL expr op)
rnSection other = pprPanic "rnSection" (ppr other)
\end{code}
%************************************************************************
%* *
Records
%* *
%************************************************************************
\begin{code}
rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
-> RnM (HsRecordBinds Name, FreeVars)
rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
= do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
; (flds', fvss) <- mapAndUnzipM rn_field flds
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
fvs `plusFV` plusFVs fvss) }
where
rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
; return (fld { hsRecFieldArg = arg' }, fvs) }
\end{code}
%************************************************************************
%* *
Arrow commands
......@@ -569,7 +590,7 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)