Commit 7f2909e0 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Improve free-variable handling for rnPat and friends (fixes Trac #1972)

As well as fixing the immediate problem (Trac #1972) this patch does
a signficant simplification and refactoring of pattern renaming.

Fewer functions, fewer parameters passed....it's all good.  But it
took much longer than I expected to figure out.

The most significant change is that the NameMaker type does *binding*
as well as *making* and, in the matchNameMaker case, checks for unused
bindings as well.  This is much tider.

(No need to merge to the 6.8 branch, but no harm either.)
parent 1476e683
......@@ -32,8 +32,8 @@ import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,
NameMaker, localNameMaker, topNameMaker, applyNameMaker,
import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker,
patSigErr)
import RnEnv ( lookupLocatedBndrRn,
......@@ -179,7 +179,7 @@ rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds =
(uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env binds
(uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
rnTopBindsRHS :: [Name] -- the names bound by these binds
-> HsValBindsLR Name RdrName
......@@ -282,10 +282,8 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do
-- Do error checking: we need to check for dups here because we
-- don't don't bind all of the variables from the ValBinds at once
-- with bindLocatedLocals any more.
--
checkDupNames doc boundNames
-- Warn about shadowing, but only in source modules
ifOptM Opt_WarnNameShadowing (checkShadowing doc boundNames)
checkDupNames doc boundNames
checkShadowing doc boundNames
-- (Note that we don't want to do this at the top level, since
-- sorting out duplicates and shadowing there happens elsewhere.
......@@ -297,7 +295,7 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do
-- import A(f)
-- g = let f = ... in f
-- should.
rnValBindsLHSFromDoc False boundNames doc fix_env binds
rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds
bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
bindersAndDoc binds =
......@@ -311,17 +309,15 @@ bindersAndDoc binds =
-- renames the left-hand sides
-- generic version used both at the top level and for local binds
-- does some error checking, but not what gets done elsewhere at the top level
rnValBindsLHSFromDoc :: Bool -- top or not
rnValBindsLHSFromDoc :: NameMaker
-> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
-> SDoc -- doc string for dup names and shadowing
-> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
-- these fixities need to be brought into scope with the names
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs)
rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs)
= do
-- rename the LHSes
mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds
mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
return $ ValBindsIn mbinds' sigs
-- assumes the LHS vars are in scope
......@@ -383,7 +379,8 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside =
let bound_names = map unLoc $ collectHsValBinders new_lhs
-- and bring them (and their fixities) into scope
bindLocalNamesFV_WithFixities bound_names new_fixities $ do
bindLocalNamesFV_WithFixities bound_names new_fixities $
warnUnusedLocalBinds bound_names $ do
-- (C) do the RHS and thing inside
(binds', dus) <- rnValBindsRHS bound_names new_lhs
......@@ -401,13 +398,6 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside =
-- bindings in the wrong order, and the type checker will complain
-- that x isn't in scope
-- check for unused binders. note that we only want to do
-- this for local ValBinds; it gets done elsewhere for
-- top-level binds (where the scoping is different)
unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)]
warnUnusedLocalBinds unused_bndrs
return (result,
-- the bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
......@@ -456,24 +446,22 @@ dupFixityDecl loc rdr_name
-- renaming a single bind
rnBindLHS :: Bool -- top if true; local if false
rnBindLHS :: NameMaker
-> SDoc
-> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
-- these fixities need to be brought into scope with the names
-> LHsBind RdrName
-- returns the renamed left-hand side,
-- and the FreeVars *of the LHS*
-- (i.e., any free variables of the pattern)
-> RnM (LHsBindLR Name RdrName)
rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat,
pat_rhs = grhss,
bind_fvs=bind_fvs,
pat_rhs_ty=pat_rhs_ty
}))
= setSrcSpan loc $ do
-- we don't actually use the FV processing of rnPatsAndThen here
(pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat
(pat',pat'_fvs) <- rnBindPat name_maker pat
return (L loc (PatBind { pat_lhs = pat',
pat_rhs = grhss,
-- we temporarily store the pat's FVs here;
......@@ -484,25 +472,26 @@ rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
-- when we rename the RHS
pat_rhs_ty = pat_rhs_ty }))
rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _),
rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _),
fun_infix = inf,
fun_matches = matches,
fun_co_fn = fun_co_fn,
bind_fvs = bind_fvs,
fun_tick = fun_tick
}))
= setSrcSpan loc $ do
newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name
return (L loc (FunBind { fun_id = L nameLoc newname,
fun_infix = inf,
fun_matches = matches,
-- we temporatily store the LHS's FVs (empty in this case) here
-- gets updated when doing the RHS below
bind_fvs = emptyFVs,
-- everything else will get ignored in the next pass
fun_co_fn = fun_co_fn,
fun_tick = fun_tick
}))
= setSrcSpan loc $
do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
return (newname, emptyFVs)
; return (L loc (FunBind { fun_id = L nameLoc newname,
fun_infix = inf,
fun_matches = matches,
-- we temporatily store the LHS's FVs (empty in this case) here
-- gets updated when doing the RHS below
bind_fvs = emptyFVs,
-- everything else will get ignored in the next pass
fun_co_fn = fun_co_fn,
fun_tick = fun_tick
})) }
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
......@@ -789,7 +778,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',_) ->
rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' ->
rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
......
......@@ -74,7 +74,7 @@ import BasicTypes ( IPName, mapIPName, Fixity )
import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
import Outputable
import Util ( sortLe )
import Util
import Maybes
import ListSetOps ( removeDups )
import List ( nubBy )
......@@ -562,17 +562,23 @@ bindLocalFixities fixes thing_inside
-- Used for nested fixity decls to bind names along with their fixities.
-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
bindLocalNamesFV_WithFixities :: [Name] -> UniqFM (Located Fixity) -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV_WithFixities names fixities cont =
-- Also check for unused binders
bindLocalNamesFV_WithFixities :: [Name]
-> UniqFM (Located Fixity)
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV_WithFixities names fixities thing_inside
= bindLocalNamesFV names $
extendFixityEnv boundFixities $
thing_inside
where
-- find the names that have fixity decls
let boundFixities = foldr
boundFixities = foldr
(\ name -> \ acc ->
-- check whether this name has a fixity decl
case lookupUFM fixities (occNameFS (nameOccName name)) of
Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
Nothing -> acc) [] names in
Nothing -> acc) [] names
-- bind the names; extend the fixity env; do the thing inside
bindLocalNamesFV names (extendFixityEnv boundFixities cont)
\end{code}
--------------------------------
......@@ -746,9 +752,8 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
= -- Check for duplicate names
checkDupNames doc_str rdr_names_w_loc `thenM_`
-- Warn about shadowing, but only in source modules
ifOptM Opt_WarnNameShadowing
(checkShadowing doc_str rdr_names_w_loc) `thenM_`
-- Warn about shadowing
checkShadowing doc_str rdr_names_w_loc `thenM_`
-- Make fresh Names and extend the environment
newLocalsRn rdr_names_w_loc `thenM` \ names ->
......@@ -847,16 +852,20 @@ checkDupNames doc_str rdr_names_w_loc
-------------------------------------
checkShadowing doc_str loc_rdr_names
= getLocalRdrEnv `thenM` \ local_env ->
= traceRn (text "shadow" <+> ppr loc_rdr_names) `thenM_`
getLocalRdrEnv `thenM` \ local_env ->
getGlobalRdrEnv `thenM` \ global_env ->
let
check_shadow (L loc rdr_name)
| rdr_name `elemLocalRdrEnv` local_env
|| not (null (lookupGRE_RdrName rdr_name global_env ))
= addWarnAt loc (shadowedNameWarn doc_str rdr_name)
| otherwise = returnM ()
| Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)]
| not (null gres) = complain (map pprNameProvenance gres)
| otherwise = return ()
where
complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str rdr_name pp_locs)
mb_local = lookupLocalRdrEnv local_env rdr_name
gres = lookupGRE_RdrName rdr_name global_env
in
mappM_ check_shadow loc_rdr_names
ifOptM Opt_WarnNameShadowing (mappM_ check_shadow loc_rdr_names)
\end{code}
......@@ -877,16 +886,13 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff ->
-- because some of the rename functions are CPSed:
-- maps the function across the list from left to right;
-- collects all the free vars into one set
mapFvRnCPS :: (a -> ((b,FreeVars) -> RnM (c, FreeVars)) -> RnM(c, FreeVars))
-> [a]
-> (([b],FreeVars) -> RnM (c, FreeVars))
-> RnM (c, FreeVars)
mapFvRnCPS _ [] cont = cont ([], emptyFVs)
mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c)
-> [a] -> ([b] -> RnM c) -> RnM c
mapFvRnCPS f (h:t) cont = f h $ \ (h',hfv) ->
mapFvRnCPS f t $ \ (t',tfv) ->
cont (h':t', hfv `plusFV` tfv)
mapFvRnCPS _ [] cont = cont []
mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
mapFvRnCPS f xs $ \ xs' ->
cont (x':xs')
\end{code}
......@@ -914,9 +920,19 @@ warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres)
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM ()
warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names)
warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names)
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
warnUnusedMatches = check_unused Opt_WarnUnusedMatches
check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
check_unused flag names thing_inside
= do { (res, res_fvs) <- thing_inside
-- Warn about unused names
; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names))
-- And return
; return (res, res_fvs) }
-------------------------
-- Helpers
......@@ -967,10 +983,10 @@ addNameClashErrRn rdr_name names
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
shadowedNameWarn doc shadow
= hsep [ptext SLIT("This binding for"),
quotes (ppr shadow),
ptext SLIT("shadows an existing binding")]
shadowedNameWarn doc rdr_name shadowed_locs
= sep [ptext SLIT("This binding for") <+> quotes (ppr rdr_name)
<+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs,
nest 2 (vcat shadowed_locs)]
$$ doc
unknownNameErr rdr_name
......
......@@ -33,8 +33,8 @@ import HscTypes ( availNames )
import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
import RnTypes ( rnHsTypeFVs,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnPat_LocalRec, localNameMaker,
rnLit,
import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat,
localRecNameMaker, rnLit,
rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize)
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
......@@ -289,7 +289,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
\begin{code}
rnExpr (HsProc pat body)
= newArrowScope $
rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ ([pat'],_) ->
rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
rnCmdTop body `thenM` \ (body',fvBody) ->
returnM (HsProc pat' body', fvBody)
......@@ -614,7 +614,7 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ ([pat'],_) -> do
; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
{ (thing, fvs3) <- thing_inside
; return ((BindStmt pat' expr' bind_op fail_op, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
......@@ -779,18 +779,12 @@ rn_rec_stmts_and_then s cont = do
-- bring them and their fixities into scope
let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv)
bindLocalNamesFV_WithFixities bound_names fix_env $ do
bindLocalNamesFV_WithFixities bound_names fix_env $
warnUnusedLocalBinds bound_names $ do
-- (C) do the right-hand-sides and thing-inside
segs <- rn_rec_stmts bound_names new_lhs_and_fv
(result, result_fvs) <- cont segs
-- (D) warn about unusued binders
let unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` result_fvs)]
warnUnusedLocalBinds unused_bndrs
-- (E) return
return (result, result_fvs)
cont segs
-- get all the fixity decls in any Let stmt
......@@ -819,7 +813,7 @@ rn_rec_stmt_lhs fix_env (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt e
rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
= do
-- should the ctxt be MDo instead?
(pat', fv_pat) <- rnPat_LocalRec fix_env pat
(pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
return [(L loc (BindStmt pat' expr a b),
fv_pat)]
......
This diff is collapsed.
......@@ -32,7 +32,7 @@ import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
lookupLocatedOccRn, lookupLocatedBndrRn,
lookupLocatedGlobalOccRn, bindTyVarsRn,
lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
lookupRecordBndr, mapFvRn, warnUnusedMatches,
lookupRecordBndr, mapFvRn,
newIPNameRn, bindPatSigTyVarsFV)
import TcRnMonad
import RdrName
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment