Commit 84ed91ab authored by simonpj's avatar simonpj
Browse files

[project @ 2003-02-21 13:27:53 by simonpj]

-------------------------------------
	Improve the "unused binding" warnings
	-------------------------------------

We've had a succession of hacks for reporting warnings for
unused bindings.  Consider

	module M( f ) where

 	f x = x

	g x = g x + h x
	h x = x

Here, g mentions itself and h, but is not itself mentioned. So
really both g and h are dead code.  We've been getting this wrong
for ages, and every hack so far has failed on some simple programs.

This commit does a much better job.  The renamer applied to a bunch
of bindings returns a NameSet.DefUses, which is a dependency-ordered
lists of def/use pairs.  It's documented in NameSet.
Given this, we can work out precisely what is not used, in a nice
tidy way.

It's less convenient in the case of type and class declarations, because
the strongly-connected-component analysis can span module boundaries.
So things are pretty much as they were for these.


As usual, there was a lot of chuffing around tidying things up.
I havn't tested it at all thoroughly yet.

Various unrelated import-decl-pruning has been done too.
parent dfc75488
...@@ -14,7 +14,12 @@ module NameSet ( ...@@ -14,7 +14,12 @@ module NameSet (
-- Free variables -- Free variables
FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV, FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
mkFVs, addOneFV, unitFV, delFV, delFVs mkFVs, addOneFV, unitFV, delFV, delFVs,
-- Defs and uses
Defs, Uses, DefUse, DefUses,
emptyDUs, usesOnly, mkDUs, plusDU,
findUses, duDefs, duUses
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -104,3 +109,76 @@ delFV n s = delFromNameSet s n ...@@ -104,3 +109,76 @@ delFV n s = delFromNameSet s n
delFVs ns s = delListFromNameSet s ns delFVs ns s = delListFromNameSet s ns
\end{code} \end{code}
%************************************************************************
%* *
Defs and uses
%* *
%************************************************************************
\begin{code}
type Defs = NameSet
type Uses = NameSet
type DefUse = (Maybe Defs, Uses)
type DefUses = [DefUse]
-- In dependency order: earlier Defs scope over later Uses
-- For items (Just ds, us), the use of any member
-- of the ds implies that all the us are used too
--
-- Also, us may mention ds
--
-- Nothing => Nothing defined in this group, but
-- nevertheless all the uses are essential.
-- Used for instance declarations, for example
emptyDUs :: DefUses
emptyDUs = []
usesOnly :: Uses -> DefUses
usesOnly uses = [(Nothing, uses)]
mkDUs :: [(Defs,Uses)] -> DefUses
mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs]
plusDU :: DefUses -> DefUses -> DefUses
plusDU = (++)
allUses :: DefUses -> Uses -> Uses
-- Collect all uses, removing defs
allUses dus uses
= foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
`minusNameSet` defs
findUses :: DefUses -> Uses -> Uses
-- Given some DefUses and some Uses,
-- find all the uses, transitively.
-- The result is a superset of the input uses;
-- and includes things defined in the input DefUses
-- (if they are used, of course)
findUses dus uses
= foldr get uses dus
where
get (Nothing, rhs_uses) uses
= rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses
| defs `intersectsNameSet` uses
= rhs_uses `unionNameSets` uses
| otherwise -- No def is used
= uses
duDefs :: DefUses -> Defs
duDefs dus = foldr get emptyNameSet dus
where
get (Nothing, u1) d2 = d2
get (Just d1, u1) d2 = d1 `unionNameSets` d2
duUses :: DefUses -> Uses
-- Defs are not eliminated
duUses dus = foldr get emptyNameSet dus
where
get (d1, u1) u2 = u1 `unionNameSets` u2
\end{code}
\ No newline at end of file
...@@ -277,9 +277,10 @@ okBindSig :: NameSet -> Sig Name -> Bool ...@@ -277,9 +277,10 @@ okBindSig :: NameSet -> Sig Name -> Bool
okBindSig ns (ClassOpSig _ _ _ _) = False okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool okClsDclSig :: Sig Name -> Bool
okClsDclSig ns (Sig _ _ _) = False okClsDclSig (Sig _ _ _) = False
okClsDclSig ns sig = sigForThisGroup ns sig okClsDclSig (SpecInstSig _ _) = False
okClsDclSig sig = True -- All others OK
okInstDclSig :: NameSet -> Sig Name -> Bool okInstDclSig :: NameSet -> Sig Name -> Bool
okInstDclSig ns (Sig _ _ _) = False okInstDclSig ns (Sig _ _ _) = False
......
...@@ -97,7 +97,7 @@ import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, ...@@ -97,7 +97,7 @@ import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName mkTupleTyCon, mkAlgTyCon, tyConName
) )
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind, mkArrowKinds, liftedTypeKind, unliftedTypeKind,
......
...@@ -25,7 +25,8 @@ import TcRnMonad ...@@ -25,7 +25,8 @@ import TcRnMonad
import RnTypes ( rnHsSigType, rnHsType, rnPat ) import RnTypes ( rnHsSigType, rnHsType, rnPat )
import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch ) import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupSigOccRn, bindPatSigTyVars, bindLocalFixities, lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
bindLocalFixities,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
) )
import CmdLineOpts ( DynFlag(..) ) import CmdLineOpts ( DynFlag(..) )
...@@ -33,7 +34,7 @@ import Digraph ( SCC(..), stronglyConnComp ) ...@@ -33,7 +34,7 @@ import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc ) import Name ( Name, nameOccName, nameSrcLoc )
import NameSet import NameSet
import RdrName ( RdrName, rdrNameOcc ) import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..) ) import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel )
import List ( unzip4 ) import List ( unzip4 )
import Outputable import Outputable
\end{code} \end{code}
...@@ -150,35 +151,18 @@ contains bindings for the binders of this particular binding. ...@@ -150,35 +151,18 @@ contains bindings for the binders of this particular binding.
\begin{code} \begin{code}
rnTopMonoBinds :: RdrNameMonoBinds rnTopMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig] -> [RdrNameSig]
-> RnM (RenamedHsBinds, FreeVars) -> RnM (RenamedHsBinds, DefUses)
-- Assumes the binders of the binding are in scope already -- The binders of the binding are in scope already;
-- Very like rnMonoBinds, but checks for missing signatures too -- the top level scope resoluttion does that
rnTopMonoBinds mbinds sigs rnTopMonoBinds mbinds sigs
= bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ ->
-- Hmm; by analogy with Ids, this doesn't look right -- Hmm; by analogy with Ids, this doesn't look right
-- Top-level bound type vars should really scope over
-- everything, but we only scope them over the other bindings
renameSigs sigs `thenM` \ siglist -> rnMonoBinds TopLevel mbinds sigs
rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) ->
checkSigs okBindSig binders siglist `thenM_`
-- Warn about missing signatures, but not in interface mode
-- (This is important when renaming bindings from 'deriving' clauses.)
getModeRn `thenM` \ mode ->
doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs ->
(if warn_missing_sigs && not (isInterfaceMode mode) then
let
type_sig_vars = [n | Sig n _ _ <- siglist]
un_sigd_binders = filter (not . (`elem` type_sig_vars))
(nameSetToList binders)
in
mappM_ missingSigWarn un_sigd_binders
else
returnM ()
) `thenM_`
returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist)
\end{code} \end{code}
...@@ -198,27 +182,28 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds ...@@ -198,27 +182,28 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group, and extend the = -- Extract all the binders in this group, and extend the
-- current scope, inventing new names for the new binders -- current scope, inventing new names for the new binders
-- This also checks that the names form a set -- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders -> bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ ->
bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds) $
-- Then install local fixity declarations -- Then install local fixity declarations
-- Notice that they scope over thing_inside too -- Notice that they scope over thing_inside too
bindLocalFixities [sig | FixSig sig <- sigs ] $ bindLocalFixities [sig | FixSig sig <- sigs ] $
-- Do the business -- Do the business
rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) -> rnMonoBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) ->
-- Now do the "thing inside" -- Now do the "thing inside"
thing_inside binds `thenM` \ (result,result_fvs) -> thing_inside binds `thenM` \ (result,result_fvs) ->
-- Final error checking -- Final error checking
let let
all_fvs = result_fvs `plusFV` bind_fvs bndrs = duDefs bind_dus
unused_binders = filter (not . (`elemNameSet` all_fvs)) new_mbinders all_uses = findUses bind_dus result_fvs
unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses)
in in
warnUnusedLocalBinds unused_binders `thenM_` warnUnusedLocalBinds unused_bndrs `thenM_`
returnM (result, delListFromNameSet all_fvs new_mbinders) returnM (result, all_uses `minusNameSet` bndrs)
where where
mbinders_w_srclocs = collectLocatedMonoBinders mbinds mbinders_w_srclocs = collectLocatedMonoBinders mbinds
doc = text "In the binding group for:" doc = text "In the binding group for:"
...@@ -226,40 +211,29 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds ...@@ -226,40 +211,29 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
\end{code} \end{code}
\begin{code}
rnMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig]
-> RnM (RenamedHsBinds, FreeVars)
-- Assumes the binders of the binding are in scope already
rnMonoBinds mbinds sigs
= renameSigs sigs `thenM` \ siglist ->
rn_mono_binds siglist mbinds `thenM` \ (binders, final_binds, bind_fvs) ->
checkSigs okBindSig binders siglist `thenM_`
returnM (final_binds, bind_fvs `plusFV` hsSigsFVs siglist)
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsubsection{ MonoBinds -- the main work is done here} \subsubsection{ MonoBinds -- the main work is done here}
%* * %* *
%************************************************************************ %************************************************************************
@rn_mono_binds@ is used by {\em both} top-level and nested bindings. @rnMonoBinds@ is used by {\em both} top-level and nested bindings.
It assumes that all variables bound in this group are already in scope. It assumes that all variables bound in this group are already in scope.
This is done {\em either} by pass 3 (for the top-level bindings), This is done {\em either} by pass 3 (for the top-level bindings),
{\em or} by @rnMonoBinds@ (for the nested ones). {\em or} by @rnMonoBinds@ (for the nested ones).
\begin{code} \begin{code}
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group rnMonoBinds :: TopLevelFlag
-> RdrNameMonoBinds -> RdrNameMonoBinds
-> RnM (NameSet, -- Binders -> [RdrNameSig]
RenamedHsBinds, -- Dependency analysed -> RnM (RenamedHsBinds, DefUses)
FreeVars) -- Free variables
-- Assumes the binders of the binding are in scope already
rnMonoBinds top_lvl mbinds sigs
= renameSigs sigs `thenM` \ siglist ->
rn_mono_binds siglist mbinds -- Rename the bindings, returning a MonoBindsInfo
= -- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as -- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned -- the strongly-connected-components (SCC) analysis is concerned
flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> flattenMonoBinds siglist mbinds `thenM` \ mbinds_info ->
...@@ -267,23 +241,39 @@ rn_mono_binds siglist mbinds ...@@ -267,23 +241,39 @@ rn_mono_binds siglist mbinds
-- Do the SCC analysis -- Do the SCC analysis
let let
scc_result = rnSCC mbinds_info scc_result = rnSCC mbinds_info
(binds_s, rhs_fvs_s) = unzip (map reconstructCycle scc_result) (binds_s, bind_dus_s) = unzip (map reconstructCycle scc_result)
bind_dus = mkDUs bind_dus_s
final_binds = foldr ThenBinds EmptyBinds binds_s final_binds = foldr ThenBinds EmptyBinds binds_s
binders = duDefs bind_dus
in
-- Check for duplicate or mis-placed signatures
checkSigs (okBindSig binders) siglist `thenM_`
-- Deal with bound and free-var calculation -- Warn about missing signatures,
-- Caller removes binders from free-var set -- but only at top level, and not in interface mode
rhs_fvs = plusFVs rhs_fvs_s -- (The latter is important when renaming bindings from 'deriving' clauses.)
bndrs = plusFVs [defs | (defs,_,_,_) <- mbinds_info] getModeRn `thenM` \ mode ->
doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs ->
(if isTopLevel top_lvl &&
warn_missing_sigs &&
not (isInterfaceMode mode)
then let
type_sig_vars = [n | Sig n _ _ <- siglist]
un_sigd_binders = filter (not . (`elem` type_sig_vars))
(nameSetToList binders)
in in
returnM (bndrs, final_binds, rhs_fvs) mappM_ missingSigWarn un_sigd_binders
else
returnM ()
) `thenM_`
returnM (final_binds, bind_dus `plusDU` usesOnly (hsSigsFVs siglist))
\end{code} \end{code}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
unique ``vertex tags'' on its output; minor plumbing required. unique ``vertex tags'' on its output; minor plumbing required.
Sigh --- need to pass along the signatures for the group of bindings,
in case any of them \fbox{\ ???\ }
\begin{code} \begin{code}
flattenMonoBinds :: [RenamedSig] -- Signatures flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds -> RdrNameMonoBinds
...@@ -406,9 +396,6 @@ a function binding, and has itself been dependency-analysed and ...@@ -406,9 +396,6 @@ a function binding, and has itself been dependency-analysed and
renamed. renamed.
\begin{code} \begin{code}
type Defs = NameSet
type Uses = NameSet
type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig]) type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig])
-- Signatures, if any, for this vertex -- Signatures, if any, for this vertex
...@@ -433,16 +420,12 @@ mkEdges nodes ...@@ -433,16 +420,12 @@ mkEdges nodes
defs `intersectsNameSet` uses defs `intersectsNameSet` uses
] ]
reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, Uses) reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses))
reconstructCycle (AcyclicSCC (defs, uses, binds, sigs)) reconstructCycle (AcyclicSCC (defs, uses, binds, sigs))
= (MonoBind binds sigs NonRecursive, uses) = (MonoBind binds sigs NonRecursive, (defs, uses))
reconstructCycle (CyclicSCC cycle) reconstructCycle (CyclicSCC cycle)
= (MonoBind this_gp_binds this_gp_sigs Recursive, = (MonoBind this_gp_binds this_gp_sigs Recursive,
unionManyNameSets uses_s `minusNameSet` unionManyNameSets defs_s) (unionManyNameSets defs_s, unionManyNameSets uses_s))
-- The uses of the cycle are the things used in any RHS
-- minus the binders of the group. Knocking them out
-- right here improves the error reporting for usused
-- bindings; e.g. f x = f x -- Otherwise unused
where where
(defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle
this_gp_binds = foldr1 AndMonoBinds binds_s this_gp_binds = foldr1 AndMonoBinds binds_s
...@@ -467,17 +450,16 @@ At the moment we don't gather free-var info from the types in ...@@ -467,17 +450,16 @@ At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars. signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code} \begin{code}
checkSigs :: (NameSet -> RenamedSig -> Bool) -- OK-sig predicbate checkSigs :: (RenamedSig -> Bool) -- OK-sig predicbate
-> NameSet -- Binders of this group
-> [RenamedSig] -> [RenamedSig]
-> RnM () -> RnM ()
checkSigs ok_sig bndrs sigs checkSigs ok_sig sigs
-- Check for (a) duplicate signatures -- Check for (a) duplicate signatures
-- (b) signatures for things not in this group -- (b) signatures for things not in this group
-- Well, I can't see the check for (b)... ToDo! -- Well, I can't see the check for (a)... ToDo!
= mappM_ unknownSigErr bad_sigs = mappM_ unknownSigErr bad_sigs
where where
bad_sigs = filter (not . ok_sig bndrs) sigs bad_sigs = filter (not . ok_sig) sigs
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for: -- because this won't work for:
......
...@@ -33,8 +33,7 @@ import Name ( Name, getName, nameIsLocalOrFrom, ...@@ -33,8 +33,7 @@ import Name ( Name, getName, nameIsLocalOrFrom,
isWiredInName, mkInternalName, mkExternalName, mkIPName, isWiredInName, mkInternalName, mkExternalName, mkIPName,
nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) nameSrcLoc, nameOccName, setNameSrcLoc, nameModule )
import NameSet import NameSet
import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour, import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused )
reportIfUnused )
import Module ( Module, ModuleName, moduleName, mkHomeModule, import Module ( Module, ModuleName, moduleName, mkHomeModule,
lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
import PrelNames ( mkUnboundName, intTyConName, import PrelNames ( mkUnboundName, intTyConName,
...@@ -318,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name ...@@ -318,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name
getGblEnv `thenM` \ gbl_env -> getGblEnv `thenM` \ gbl_env ->
let let
avail_env = imp_env (tcg_imports gbl_env) avail_env = imp_env (tcg_imports gbl_env)
occ = rdrNameOcc rdr_name
in in
case lookupAvailEnv avail_env cls_name of case lookupAvailEnv_maybe avail_env cls_name of
Nothing -> Nothing ->
-- If the class itself isn't in scope, then cls_name will -- If the class itself isn't in scope, then cls_name will
-- be unboundName, and there'll already be an error for -- be unboundName, and there'll already be an error for
...@@ -343,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name ...@@ -343,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name
-- NB: qualified names are rejected by the parser -- NB: qualified names are rejected by the parser
lookupOrigName rdr_name lookupOrigName rdr_name
where
occ = rdrNameOcc rdr_name
lookupSysBndr :: RdrName -> RnM Name lookupSysBndr :: RdrName -> RnM Name
-- Used for the 'system binders' in a data type or class declaration -- Used for the 'system binders' in a data type or class declaration
...@@ -770,7 +768,7 @@ bindLocalsRn doc rdr_names enclosed_scope ...@@ -770,7 +768,7 @@ bindLocalsRn doc rdr_names enclosed_scope
-- binLocalsFVRn is the same as bindLocalsRn -- binLocalsFVRn is the same as bindLocalsRn
-- except that it deals with free vars -- except that it deals with free vars
bindLocalsFVRn doc rdr_names enclosed_scope bindLocalsFV doc rdr_names enclosed_scope
= bindLocalsRn doc rdr_names $ \ names -> = bindLocalsRn doc rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) -> enclosed_scope names `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names) returnM (thing, delListFromNameSet fvs names)
...@@ -793,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope ...@@ -793,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope
bindLocatedLocalsRn doc_str located_tyvars $ \ names -> bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replaceTyVarName tyvar_names names) enclosed_scope (zipWith replaceTyVarName tyvar_names names)
bindPatSigTyVars :: [RdrNameHsType] bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
-- Find the type variables in the pattern type -- Find the type variables in the pattern type
-- signatures that must be brought into scope -- signatures that must be brought into scope
bindPatSigTyVars tys enclosed_scope bindPatSigTyVars tys thing_inside
= getLocalRdrEnv `thenM` \ name_env -> = getLocalRdrEnv `thenM` \ name_env ->
getSrcLocM `thenM` \ loc -> getSrcLocM `thenM` \ loc ->
let let
...@@ -814,10 +810,15 @@ bindPatSigTyVars tys enclosed_scope ...@@ -814,10 +810,15 @@ bindPatSigTyVars tys enclosed_scope
located_tyvars = [(tv, loc) | tv <- forall_tyvars] located_tyvars = [(tv, loc) | tv <- forall_tyvars]
doc_sig = text "In a pattern type-signature" doc_sig = text "In a pattern type-signature"
in in
bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> bindLocatedLocalsRn doc_sig located_tyvars thing_inside
enclosed_scope `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
bindPatSigTyVarsFV :: [RdrNameHsType]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindPatSigTyVarsFV tys thing_inside
= bindPatSigTyVars tys $ \ tvs ->
thing_inside `thenM` \ (result,fvs) ->
returnM (result, fvs `delListFromNameSet` tvs)
------------------------------------- -------------------------------------
checkDupOrQualNames, checkDupNames :: SDoc checkDupOrQualNames, checkDupNames :: SDoc
...@@ -896,7 +897,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs ...@@ -896,7 +897,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs
else Just parent, else Just parent,
gre_prov = mk_provenance name, gre_prov = mk_provenance name,
gre_deprec = lookupDeprec deprecs name} gre_deprec = lookupDeprec deprecs name}
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -69,7 +69,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) ...@@ -69,7 +69,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
= addSrcLoc (getMatchLoc match) $ = addSrcLoc (getMatchLoc match) $
-- Deal with the rhs type signature -- Deal with the rhs type signature
bindPatSigTyVars rhs_sig_tys $ bindPatSigTyVarsFV rhs_sig_tys $
doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
(case maybe_rhs_sig of (case maybe_rhs_sig of
Nothing -> returnM (Nothing, emptyFVs) Nothing -> returnM (Nothing, emptyFVs)
...@@ -84,7 +84,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) ...@@ -84,7 +84,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
-- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
where where
rhs_sig_tys = case maybe_rhs_sig of rhs_sig_tys = case maybe_rhs_sig of
Nothing -> [] Nothing -> []
...@@ -455,10 +455,10 @@ rnBracket (DecBr group) ...@@ -455,10 +455,10 @@ rnBracket (DecBr group)
updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $ updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
rnSrcDecls group `thenM` \ (tcg_env, group', fvs) -> rnSrcDecls group `thenM` \ (tcg_env, group', dus) ->
-- Discard the tcg_env; it contains only extra info about fixity -- Discard the tcg_env; it contains only extra info about fixity
returnM (DecBr group', fvs) returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -515,7 +515,9 @@ rnNormalStmts ctxt (LetStmt binds : stmts) ...@@ -515,7 +515,9 @@ rnNormalStmts ctxt (LetStmt binds : stmts)
ok _ _ = True ok _ _ = True
rnNormalStmts ctxt (ParStmt stmtss : stmts) rnNormalStmts ctxt (ParStmt stmtss : stmts)
= mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) -> = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
checkM opt_GlasgowExts parStmtErr `thenM_`
mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss `thenM` \ (stmtss', fv_stmtss) ->
let let
bndrss = map collectStmtsBinders stmtss' bndrss = map collectStmtsBinders stmtss'
in in
...@@ -549,8 +551,6 @@ rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts) ...@@ -549,8 +551,6 @@ rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
type Defs = NameSet