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 (
-- Free variables
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
#include "HsVersions.h"
......@@ -104,3 +109,76 @@ delFV n s = delFromNameSet s n
delFVs ns s = delListFromNameSet s ns
\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
okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
okClsDclSig ns (Sig _ _ _) = False
okClsDclSig ns sig = sigForThisGroup ns sig
okClsDclSig :: Sig Name -> Bool
okClsDclSig (Sig _ _ _) = False
okClsDclSig (SpecInstSig _ _) = False
okClsDclSig sig = True -- All others OK
okInstDclSig :: NameSet -> Sig Name -> Bool
okInstDclSig ns (Sig _ _ _) = False
......
......@@ -97,7 +97,7 @@ import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName
)
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) )
import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind,
......
......@@ -25,7 +25,8 @@ import TcRnMonad
import RnTypes ( rnHsSigType, rnHsType, rnPat )
import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
lookupSigOccRn, bindPatSigTyVars, bindLocalFixities,
lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
bindLocalFixities,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
......@@ -33,7 +34,7 @@ import Digraph ( SCC(..), stronglyConnComp )
import Name ( Name, nameOccName, nameSrcLoc )
import NameSet
import RdrName ( RdrName, rdrNameOcc )
import BasicTypes ( RecFlag(..) )
import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel )
import List ( unzip4 )
import Outputable
\end{code}
......@@ -150,35 +151,18 @@ contains bindings for the binders of this particular binding.
\begin{code}
rnTopMonoBinds :: RdrNameMonoBinds
-> [RdrNameSig]
-> RnM (RenamedHsBinds, FreeVars)
-> RnM (RenamedHsBinds, DefUses)
-- Assumes the binders of the binding are in scope already
-- Very like rnMonoBinds, but checks for missing signatures too
-- The binders of the binding are in scope already;
-- the top level scope resoluttion does that
rnTopMonoBinds mbinds sigs
= bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
= bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ ->
-- 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 ->
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)
rnMonoBinds TopLevel mbinds sigs
\end{code}
......@@ -198,27 +182,28 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group, and extend the
-- current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders ->
bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ ->
bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds) $
-- Then install local fixity declarations
-- Notice that they scope over thing_inside too
bindLocalFixities [sig | FixSig sig <- sigs ] $
-- Do the business
rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) ->
rnMonoBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) ->
-- Now do the "thing inside"
thing_inside binds `thenM` \ (result,result_fvs) ->
-- Final error checking
let
all_fvs = result_fvs `plusFV` bind_fvs
unused_binders = filter (not . (`elemNameSet` all_fvs)) new_mbinders
bndrs = duDefs bind_dus
all_uses = findUses bind_dus result_fvs
unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses)
in
warnUnusedLocalBinds unused_binders `thenM_`
warnUnusedLocalBinds unused_bndrs `thenM_`
returnM (result, delListFromNameSet all_fvs new_mbinders)
returnM (result, all_uses `minusNameSet` bndrs)
where
mbinders_w_srclocs = collectLocatedMonoBinders mbinds
doc = text "In the binding group for:"
......@@ -226,40 +211,29 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
\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}
%* *
%************************************************************************
@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.
This is done {\em either} by pass 3 (for the top-level bindings),
{\em or} by @rnMonoBinds@ (for the nested ones).
\begin{code}
rn_mono_binds :: [RenamedSig] -- Signatures attached to this group
rnMonoBinds :: TopLevelFlag
-> RdrNameMonoBinds
-> RnM (NameSet, -- Binders
RenamedHsBinds, -- Dependency analysed
FreeVars) -- Free variables
-> [RdrNameSig]
-> RnM (RenamedHsBinds, DefUses)
-- 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
-- the strongly-connected-components (SCC) analysis is concerned
flattenMonoBinds siglist mbinds `thenM` \ mbinds_info ->
......@@ -267,23 +241,39 @@ rn_mono_binds siglist mbinds
-- Do the SCC analysis
let
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
binders = duDefs bind_dus
in
-- Check for duplicate or mis-placed signatures
checkSigs (okBindSig binders) siglist `thenM_`
-- Deal with bound and free-var calculation
-- Caller removes binders from free-var set
rhs_fvs = plusFVs rhs_fvs_s
bndrs = plusFVs [defs | (defs,_,_,_) <- mbinds_info]
-- Warn about missing signatures,
-- but only at top level, and not in interface mode
-- (The latter is important when renaming bindings from 'deriving' clauses.)
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
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}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
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}
flattenMonoBinds :: [RenamedSig] -- Signatures
-> RdrNameMonoBinds
......@@ -406,9 +396,6 @@ a function binding, and has itself been dependency-analysed and
renamed.
\begin{code}
type Defs = NameSet
type Uses = NameSet
type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig])
-- Signatures, if any, for this vertex
......@@ -433,16 +420,12 @@ mkEdges nodes
defs `intersectsNameSet` uses
]
reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, Uses)
reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses))
reconstructCycle (AcyclicSCC (defs, uses, binds, sigs))
= (MonoBind binds sigs NonRecursive, uses)
= (MonoBind binds sigs NonRecursive, (defs, uses))
reconstructCycle (CyclicSCC cycle)
= (MonoBind this_gp_binds this_gp_sigs Recursive,
unionManyNameSets uses_s `minusNameSet` unionManyNameSets defs_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
(unionManyNameSets defs_s, unionManyNameSets uses_s))
where
(defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle
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
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
checkSigs :: (NameSet -> RenamedSig -> Bool) -- OK-sig predicbate
-> NameSet -- Binders of this group
checkSigs :: (RenamedSig -> Bool) -- OK-sig predicbate
-> [RenamedSig]
-> RnM ()
checkSigs ok_sig bndrs sigs
checkSigs ok_sig sigs
-- Check for (a) duplicate signatures
-- (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
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
-- because this won't work for:
......
......@@ -33,8 +33,7 @@ import Name ( Name, getName, nameIsLocalOrFrom,
isWiredInName, mkInternalName, mkExternalName, mkIPName,
nameSrcLoc, nameOccName, setNameSrcLoc, nameModule )
import NameSet
import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour,
reportIfUnused )
import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused )
import Module ( Module, ModuleName, moduleName, mkHomeModule,
lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C )
import PrelNames ( mkUnboundName, intTyConName,
......@@ -318,8 +317,9 @@ lookupInstDeclBndr cls_name rdr_name
getGblEnv `thenM` \ gbl_env ->
let
avail_env = imp_env (tcg_imports gbl_env)
occ = rdrNameOcc rdr_name
in
case lookupAvailEnv avail_env cls_name of
case lookupAvailEnv_maybe avail_env cls_name of
Nothing ->
-- If the class itself isn't in scope, then cls_name will
-- be unboundName, and there'll already be an error for
......@@ -343,8 +343,6 @@ lookupInstDeclBndr cls_name rdr_name
-- NB: qualified names are rejected by the parser
lookupOrigName rdr_name
where
occ = rdrNameOcc rdr_name
lookupSysBndr :: RdrName -> RnM Name
-- Used for the 'system binders' in a data type or class declaration
......@@ -770,7 +768,7 @@ bindLocalsRn doc rdr_names enclosed_scope
-- binLocalsFVRn is the same as bindLocalsRn
-- except that it deals with free vars
bindLocalsFVRn doc rdr_names enclosed_scope
bindLocalsFV doc rdr_names enclosed_scope
= bindLocalsRn doc rdr_names $ \ names ->
enclosed_scope names `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
......@@ -793,13 +791,11 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope (zipWith replaceTyVarName tyvar_names names)
bindPatSigTyVars :: [RdrNameHsType]
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
bindPatSigTyVars tys enclosed_scope
bindPatSigTyVars tys thing_inside
= getLocalRdrEnv `thenM` \ name_env ->
getSrcLocM `thenM` \ loc ->
let
......@@ -814,10 +810,15 @@ bindPatSigTyVars tys enclosed_scope
located_tyvars = [(tv, loc) | tv <- forall_tyvars]
doc_sig = text "In a pattern type-signature"
in
bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
enclosed_scope `thenM` \ (thing, fvs) ->
returnM (thing, delListFromNameSet fvs names)
bindLocatedLocalsRn doc_sig located_tyvars thing_inside
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
......@@ -896,7 +897,6 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs
else Just parent,
gre_prov = mk_provenance name,
gre_deprec = lookupDeprec deprecs name}
\end{code}
\begin{code}
......
......@@ -69,7 +69,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
= addSrcLoc (getMatchLoc match) $
-- Deal with the rhs type signature
bindPatSigTyVars rhs_sig_tys $
bindPatSigTyVarsFV rhs_sig_tys $
doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnM (Nothing, emptyFVs)
......@@ -84,7 +84,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_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
rhs_sig_tys = case maybe_rhs_sig of
Nothing -> []
......@@ -455,10 +455,10 @@ rnBracket (DecBr group)
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
returnM (DecBr group', fvs)
returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
\end{code}
%************************************************************************
......@@ -515,7 +515,9 @@ rnNormalStmts ctxt (LetStmt binds : stmts)
ok _ _ = True
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
bndrss = map collectStmtsBinders stmtss'
in
......@@ -549,8 +551,6 @@ rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
%************************************************************************
\begin{code}
type Defs = NameSet
type Uses = NameSet -- Same as FreeVars really
type FwdRefs = NameSet
type Segment = (Defs,
Uses, -- May include defs
......@@ -620,9 +620,9 @@ rn_mdo_stmt (BindStmt pat expr src_loc)
[BindStmt pat' expr' src_loc])
rn_mdo_stmt (LetStmt binds)
= rnBinds binds `thenM` \ (binds', fv_binds) ->
returnM (mkNameSet (collectHsBinders binds'),
fv_binds, emptyNameSet, [LetStmt binds'])
= rnBinds binds `thenM` \ (binds', du_binds) ->
returnM (duDefs du_binds, duUses du_binds,
emptyNameSet, [LetStmt binds'])
rn_mdo_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo
= pprPanic "rn_mdo_stmt" (ppr stmt)
......@@ -923,6 +923,8 @@ checkTH e what -- Raise an error in a stage-1 compiler
nest 2 (ppr e)])
#endif
parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
badIpBinds binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
(ppr binds)
......
......@@ -15,7 +15,7 @@ module RnHiFiles (
import DriverState ( v_GhcMode, isCompManagerMode )
import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( opt_IgnoreIfacePragmas, verbosity )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Parser ( parseIface )
import HscTypes ( ModIface(..), emptyModIface,
ExternalPackageState(..), noDependencies,
......@@ -52,7 +52,7 @@ import Module ( Module, ModuleName, ModLocation(ml_hi_file),
extendModuleEnv, lookupModuleEnvByName
)
import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName )
import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc,
import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2,
mkDataConWrapperOcc, mkDataConWorkerOcc )
import TyCon ( DataConDetails(..) )
......
......@@ -41,7 +41,6 @@ import NameSet
import Module ( Module, isHomeModule )
import PrelNames ( hasKey, fractionalClassKey, numClassKey,
integerTyConName, doubleTyConName )
import FiniteMap
import Outputable
import Bag
import Maybe( fromJust )
......
......@@ -44,8 +44,8 @@ import OccName ( varName )
import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, lookupRdrEnv, rdrEnvToList,
emptyRdrEnv, foldRdrEnv, rdrEnvElts, mkRdrUnqual, isQual, mkUnqual )
import Outputable
import Maybe ( isJust, isNothing, catMaybes, fromMaybe )
import Maybes ( orElse, expectJust )
import Maybe ( isJust, isNothing, catMaybes )
import Maybes ( orElse )
import ListSetOps ( removeDups )
import Util ( sortLt, notNull )
import List ( partition, insert )
......@@ -554,14 +554,12 @@ exports_from_avail Nothing rdr_env
-- keeping only things that are (a) qualified,
-- (b) locally defined, (c) a 'main' name
-- Then we look up in the entity-avail-env
return [ avail
return [ lookupAvailEnv entity_avail_env name
| (rdr_name, gres) <- rdrEnvToList rdr_env,
isQual rdr_name, -- Avoid duplicates
GRE { gre_name = name,
gre_parent = Nothing, -- Main things only
gre_prov = LocalDef } <- gres,
let avail = expectJust "exportsFromAvail"
(lookupAvailEnv entity_avail_env name)
gre_prov = LocalDef } <- gres
]
}
......@@ -614,8 +612,7 @@ exports_from_avail (Just export_items) rdr_env
-- Get the AvailInfo for the parent of the specified name
let
parent = gre_parent gre `orElse` gre_name gre
avail = expectJust "exportsFromAvail2"
(lookupAvailEnv entity_avail_env parent)
avail = lookupAvailEnv entity_avail_env parent
in
-- Filter out the bits we want
case filterAvail ie avail of {
......@@ -697,28 +694,15 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main")
%*********************************************************
\begin{code}
reportUnusedNames :: TcGblEnv
-> NameSet -- Used in this module
-> TcRn m ()
reportUnusedNames gbl_env used_names
reportUnusedNames :: TcGblEnv -> DefUses -> TcRn m ()
reportUnusedNames gbl_env dus
= warnUnusedModules unused_imp_mods `thenM_`
warnUnusedTopBinds bad_locals `thenM_`
warnUnusedImports bad_imports `thenM_`
printMinimalImports minimal_imports
where
direct_import_mods :: [ModuleName]
direct_import_mods = map (moduleName . fst)
(moduleEnvElts (imp_mods (tcg_imports gbl_env)))
-- Now, a use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
really_used_names :: NameSet
really_used_names = used_names `unionNameSets`
mkNameSet [ parent
| GRE{ gre_name = name,
gre_parent = Just parent }
<- defined_names,
name `elemNameSet` used_names]
used_names :: NameSet
used_names = findUses dus emptyNameSet
-- Collect the defined names from the in-scope environment
-- Look for the qualified ones only, else get duplicates
......@@ -728,8 +712,17 @@ reportUnusedNames gbl_env used_names
| otherwise = acc
defined_and_used, defined_but_not_used :: [GlobalRdrElt]
(defined_and_used, defined_but_not_used) = partition used defined_names
used gre = gre_name gre `elemNameSet` really_used_names
(defined_and_used, defined_but_not_used) = partition is_used defined_names
is_used gre = n `elemNameSet` used_names || any (`elemNameSet` used_names) kids
-- The 'kids' part is because a use of C implies a use of T,
-- if C was brought into scope by T(..) or T(C)
where
n = gre_name gre
kids = case lookupAvailEnv_maybe avail_env n of
Just (AvailTC n ns) -> ns
other -> [] -- Ids, class ops and datacons
-- (The latter two give Nothing)
-- Filter out the ones that are
-- (a) defined in this module, and
......@@ -737,7 +730,6 @@ reportUnusedNames gbl_env used_names
-- The latter have an Internal Name, so we can filter them out easily
bad_locals :: [GlobalRdrElt]
bad_locals = filter is_bad defined_but_not_used
is_bad :: GlobalRdrElt -> Bool
is_bad gre = isLocalGRE gre && isExternalName (gre_name gre)
......@@ -790,6 +782,13 @@ reportUnusedNames gbl_env used_names
-- Add an empty collection of imports for a module
-- from which we have sucked only instance decls
imports = tcg_imports gbl_env
avail_env = imp_env imports