-- 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"
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
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
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,
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(..) )
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}
\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}
= -- 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:"
\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
- -> RdrNameMonoBinds
- -> RnM (NameSet, -- Binders
- RenamedHsBinds, -- Dependency analysed
- FreeVars) -- Free variables
-
-rn_mono_binds siglist mbinds
- = -- Rename the bindings, returning a MonoBindsInfo
+rnMonoBinds :: TopLevelFlag
+ -> RdrNameMonoBinds
+ -> [RdrNameSig]
+ -> RnM (RenamedHsBinds, DefUses)
+
+-- Assumes the binders of the binding are in scope already
+
+rnMonoBinds top_lvl mbinds sigs
+ = renameSigs sigs `thenM` \ siglist ->
+
+ -- 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 ->
+ flattenMonoBinds siglist mbinds `thenM` \ mbinds_info ->
-- 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
-
- -- 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]
+ binders = duDefs bind_dus
in
- returnM (bndrs, final_binds, rhs_fvs)
+
+ -- Check for duplicate or mis-placed signatures
+ checkSigs (okBindSig binders) siglist `thenM_`
+
+ -- 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
+ 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
renamed.
\begin{code}
-
-type Defs = NameSet
-type Uses = NameSet
type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig])
-- Signatures, if any, for this vertex
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
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:
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,
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
-- 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
-- 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)
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
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
else Just parent,
gre_prov = mk_provenance name,
gre_deprec = lookupDeprec deprecs name}
-
\end{code}
\begin{code}
= 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)
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 -> []
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}
%************************************************************************
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
%************************************************************************
\begin{code}
-type Defs = NameSet
-type Uses = NameSet -- Same as FreeVars really
type FwdRefs = NameSet
type Segment = (Defs,
Uses, -- May include defs
[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)
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)
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,
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(..) )
import Module ( Module, isHomeModule )
import PrelNames ( hasKey, fractionalClassKey, numClassKey,
integerTyConName, doubleTyConName )
-import FiniteMap
import Outputable
import Bag
import Maybe( fromJust )
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 )
-- 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
]
}
-- 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 {
%*********************************************************
\begin{code}
-reportUnusedNames :: TcGblEnv
- -> NameSet -- Used in this module
- -> TcRn m ()
-reportUnusedNames gbl_env used_names
- = warnUnusedModules unused_imp_mods `thenM_`
- warnUnusedTopBinds bad_locals `thenM_`
- warnUnusedImports bad_imports `thenM_`
+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
| 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
-- 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)
-- 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
+
+ direct_import_mods :: [ModuleName]
+ direct_import_mods = map (moduleName . fst)
+ (moduleEnvElts (imp_mods imports))
+
-- unused_imp_mods are the directly-imported modules
-- that are not mentioned in minimal_imports1
-- [Note: not 'minimal_imports', because that includes direcly-imported
-> TcRnTypes.RnM (b, NameSet.FreeVars) ;
1 rnBinds :: RdrHsSyn.RdrNameHsBinds
- -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
+ -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ;
1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
- -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) ;
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.DefUses) ;
-> TcRnTypes.RnM (b, NameSet.FreeVars) ;
rnBinds :: RdrHsSyn.RdrNameHsBinds
- -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ;
+ -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ;
rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName
- -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars)
+ -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.DefUses)
rnMonoBindsAndThen, renameSigs, checkSigs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
newLocalsRn, lookupGlobalOccRn,
- bindLocalsFVRn, bindPatSigTyVars,
+ bindLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn,
)
import TcRnMonad
-import BasicTypes ( FixitySig(..) )
+import BasicTypes ( FixitySig(..), TopLevelFlag(..) )
import HscTypes ( ExternalPackageState(..), FixityEnv,
Deprecations(..), plusDeprecs )
import Module ( moduleEnvElts )
\begin{code}
-rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, DefUses)
rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _,
hs_tyclds = tycl_decls,
$ do {
-- Rename other declarations
- (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ;
- (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
- (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ;
- (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ;
- (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
- (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
- (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
+ (rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ;
+
+ -- You might think that we could build proper def/use information
+ -- for type and class declarations, but they can be involved
+ -- in mutual recursion across modules, and we only do the SCC
+ -- analysis for them in the type checker.
+ -- So we content ourselves with gathering uses only; that
+ -- means we'll only report a declaration as unused if it isn't
+ -- mentioned at all. Ah well.
+ (rn_tycl_decls, src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ;
+ (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
+ (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ;
+ (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ;
+ (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ;
+ (rn_core_decls, src_fvs6) <- mapFvRn rnCoreDecl core_decls ;
let {
rn_group = HsGroup { hs_valds = rn_val_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
hs_coreds = rn_core_decls } ;
- src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
- src_fvs5, src_fvs6, src_fvs7] } ;
- traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
+ src_fvs4, src_fvs5, src_fvs6] ;
+ src_dus = bind_dus `plusDU` usesOnly other_fvs
+ } ;
+
tcg_env <- getGblEnv ;
- return (tcg_env, rn_group, src_fvs)
+ return (tcg_env, rn_group, src_dus)
}}}
\end{code}
of the loop too, and it must be defined in this module.
\begin{code}
-rnTopBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
-rnTopBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
-rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
- -- The parser doesn't produce other forms
-
-rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
+rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, DefUses)
-- This version assumes that the binders are already in scope
-- It's used only in 'mdo'
-rnBinds EmptyBinds = returnM (EmptyBinds, emptyFVs)
-rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
+rnBinds EmptyBinds = returnM (EmptyBinds, emptyDUs)
+rnBinds (MonoBind bind sigs _) = rnMonoBinds NotTopLevel bind sigs
rnBinds b@(IPBinds bind _) = addErr (badIpBinds b) `thenM_`
- returnM (EmptyBinds, emptyFVs)
+ returnM (EmptyBinds, emptyDUs)
rnBindsAndThen :: RdrNameHsBinds
-> (RenamedHsBinds -> RnM (result, FreeVars))
--
-- But the (unqualified) method names are in scope
bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' ->
- checkSigs okInstDclSig (mkNameSet binders) uprags' `thenM_`
+ checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_`
returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
meth_fvs `plusFV` hsSigsFVs uprags')
returnM (IfaceRuleOut fn' rule)
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
- = addSrcLoc src_loc $
- bindPatSigTyVars (collectRuleBndrSigTys vars) $
+ = addSrcLoc src_loc $
+ bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
- bindLocalsFVRn doc (map get_var vars) $ \ ids ->
+ bindLocalsFV doc (map get_var vars) $ \ ids ->
mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) ->
rnExpr lhs `thenM` \ (lhs', fv_lhs) ->
in
checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_`
mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' ->
- let
- binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
- in
- renameSigs non_op_sigs `thenM` \ non_ops' ->
- checkSigs okClsDclSig binders non_ops' `thenM_`
+ renameSigs non_op_sigs `thenM` \ non_ops' ->
+ checkSigs okClsDclSig non_ops' `thenM_`
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name )
import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn,
newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn,
- bindPatSigTyVars, bindLocalsFVRn, warnUnusedMatches )
+ bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches )
import TcRnMonad
import PrelNames( cCallishClassKeys, eqStringName, eqClassName, ordClassName,
-- f x x = 1
rnPatsAndThen ctxt pats thing_inside
- = bindPatSigTyVars pat_sig_tys $
- bindLocalsFVRn doc_pat bndrs $ \ new_bndrs ->
+ = bindPatSigTyVarsFV pat_sig_tys $
+ bindLocalsFV doc_pat bndrs $ \ new_bndrs ->
rnPats pats `thenM` \ (pats', pat_fvs) ->
thing_inside pats' `thenM` \ (res, res_fvs) ->
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcTyVarSet,
- SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
+ SourceType(..), PredType, TyVarDetails(VanillaTv),
tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
tcSplitMethodTy, tcSplitPhiTy, mkGenTyConApp,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy
)
import CoreFVs ( idFreeTyVars )
-import Class ( Class )
import DataCon ( DataCon,dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
import PprType ( pprPred, pprParendType )
-import Subst ( emptyInScopeSet, mkSubst, substTy, substTyWith, substTheta, mkTyVarSubst )
+import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst )
import Literal ( inIntRange )
import Var ( TyVar )
import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) )
isClassOpSig, isPragSig,
placeHolderType
)
-import BasicTypes ( RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
import TyCon ( tyConGenInfo )
import Subst ( substTyWith )
import MkId ( mkDictSelId, mkDefaultMethodId )
-import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
+import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import NameSet ( emptyNameSet, unitNameSet )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, reportIfUnused )
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused )
import Outputable
import Var ( TyVar )
import CmdLineOpts
pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
-import InstEnv ( InstEnv, simpleDFunClassTyCon )
+import InstEnv ( simpleDFunClassTyCon )
import TcMonoType ( tcHsPred )
import TcSimplify ( tcSimplifyDeriv )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
-import RnEnv ( bindLocalsFVRn )
+import RnEnv ( bindLocalsFV )
import TcRnMonad ( thenM, returnM, mapAndUnzipM )
import HscTypes ( DFunId )
-- Rename to get RenamedBinds.
-- The only tricky bit is that the extra_binds must scope
-- over the method bindings for the instances.
- bindLocalsFVRn (ptext (SLIT("deriving"))) mbinders $ \ _ ->
- rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, fvs) ->
+ bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ ->
+ rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, dus) ->
mapAndUnzipM rn_meths method_binds_s `thenM` \ (rn_method_binds_s, fvs_s) ->
returnM ((rn_method_binds_s, rn_extra_binds),
- fvs `plusFV` plusFVs fvs_s)
+ duUses dus `plusFV` plusFVs fvs_s)
) `thenM` \ ((rn_method_binds_s, rn_extra_binds), fvs) ->
let
new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s
)
import qualified Type ( getTyVar_maybe )
import Rules ( extendRuleBase )
-import Id ( idName, isLocalId, isDataConWrapId_maybe )
+import Id ( idName, isLocalId )
import Var ( TyVar, Id, idType )
import VarSet
import VarEnv
import CoreSyn ( IdCoreRule )
-import DataCon ( DataCon, dataConWrapId )
+import DataCon ( DataCon )
import TyCon ( TyCon, DataConDetails )
import Class ( Class, ClassOpItem )
import Name ( Name, NamedThing(..),
import BasicTypes ( EP )
import Module ( Module )
import InstEnv ( InstEnv, extendInstEnv )
-import Maybes ( seqMaybe )
import SrcLoc ( SrcLoc )
import Outputable
import Maybe ( isJust )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
isSigmaTy, mkFunTy, mkFunTys,
- mkTyConApp, mkClassPred, tcFunArgTy,
+ mkTyConApp, mkClassPred,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind,
- tcSplitSigmaTy, tcTyConAppTyCon,
- tidyOpenType
+ tcSplitSigmaTy, tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId )
import Name ( Name )
-import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons, isClassTyCon )
+import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy )
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWorkId_maybe )
+import Id ( Id, mkVanillaGlobal, mkLocalId )
import MkId ( mkFCallId )
import IdInfo
import TyCon ( tyConDataCons, tyConTyVars )
import UniqSupply ( initUs_ )
import Outputable
import Util ( zipWithEqual, dropList, equalLength )
-import HscTypes ( TyThing(..), typeEnvIds )
+import HscTypes ( typeEnvIds )
import CmdLineOpts ( DynFlag(..) )
\end{code}
import Class ( Class, classBigSig )
import Var ( idName, idType )
import NameSet
-import Id ( setIdLocalExported )
import MkId ( mkDictFunId, rUNTIME_ERROR_ID )
import FunDeps ( checkInstFDs )
import Generics ( validGenericInstanceType )
#include "HsVersions.h"
import HsSyn ( HsType(..), HsTyVarBndr(..), HsTyOp(..),
- Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
+ Sig(..), HsPred(..), HsTupCon(..), hsTyVarNames )
import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
import TcHsSyn ( TcId )
import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType, zonkTcType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt, newOpenTypeKind
)
-import TcUnify ( unifyKind, unifyOpenTypeKind, unifyFunKind )
+import TcUnify ( unifyKind, unifyFunKind )
import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..),
TcTyVar, TcKind, TcThetaType, TcTauType,
mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind,
zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
- liftedTypeKind, unliftedTypeKind, mkArrowKind, eqKind,
- mkArrowKinds, tcSplitFunTy_maybe, tcSplitForAllTys
+ liftedTypeKind, unliftedTypeKind, eqKind,
+ tcSplitFunTy_maybe, tcSplitForAllTys
)
import qualified Type ( splitFunTys )
import Inst ( Inst, InstOrigin(..), newMethod, instToId )
import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
ruleDeclFVs, instDeclFVs, tyClDeclFVs )
import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
- zonkTopBinds, zonkTopDecls, mkHsLet,
+ zonkTopDecls, mkHsLet,
zonkTopExpr, zonkTopBndrs
)
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv,
- tcExtendGlobalEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
tcLookupId
isLocalGRE )
#endif
-import Maybe ( catMaybes )
import Panic ( showException )
import List ( partition )
import Util ( sortLt )
traceRn (text "rn1a") ;
-- Rename and type check the declarations
- (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
+ (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
setGblEnv tcg_env $ do {
traceRn (text "rn3") ;
setGblEnv tcg_env $ do {
-- Report unused names
- let { used_fvs = src_fvs `plusFV` export_fvs } ;
- reportUnusedNames tcg_env used_fvs ;
+ let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
+ reportUnusedNames tcg_env all_dus ;
-- Dump output and return
tcDump tcg_env ;
-- rnSrcDecls handles fixity decls etc too, which won't occur
-- but that doesn't matter
let { local_group = mkGroup local_decls } ;
- (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
+ (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
(rnSrcDecls local_group) ;
failIfErrsM ;
-- Get the supporting decls
- rn_imp_decls <- slurpImpDecls fvs ;
+ rn_imp_decls <- slurpImpDecls (duUses dus) ;
let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
-- Dump trace of renaming part
%************************************************************************
\begin{code}
-tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
+tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
-
tcRnSrcDecls decls
= do { -- Do all the declarations
- ((tc_envs, fvs), lie) <- getLIE (tc_rn_src_decls decls) ;
+ ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
-- tcSimplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
- fvs)
+ dus)
}}
-tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), FreeVars)
+tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
tc_rn_src_decls ds
= do { let { (first_group, group_tail) = findSplice ds } ;
-- If ds is [] we get ([], Nothing)
-- Type check the decls up to, but not including, the first splice
- (tc_envs@(_,tcl_env), src_fvs1) <- tcRnGroup first_group ;
+ (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
-- Bale out if errors; for example, error recovery when checking
-- the RHS of 'main' can mean that 'main' is not in the envt for
case group_tail of {
Nothing -> do { -- Last thing: check for `main'
(tcg_env, main_fvs) <- checkMain ;
- return ((tcg_env, tcl_env), src_fvs1 `plusFV` main_fvs)
+ return ((tcg_env, tcl_env),
+ src_dus1 `plusDU` usesOnly main_fvs)
} ;
-- If there's a splice, we must carry on
#else
-- Rename the splice expression, and get its supporting decls
- (rn_splice_expr, fvs) <- initRn SourceMode $
- addSrcLoc splice_loc $
- rnExpr splice_expr ;
- tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ;
+ (rn_splice_expr, splice_fvs) <- initRn SourceMode $
+ addSrcLoc splice_loc $
+ rnExpr splice_expr ;
+ tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
setGblEnv tcg_env $ do {
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Glue them on the front of the remaining decls and loop
- (tc_envs, src_fvs2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
+ (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
- return (tc_envs, src_fvs1 `plusFV` src_fvs2)
+ return (tcg_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
}
#endif /* GHCI */
}}}
monad; it augments it and returns the new TcGblEnv.
\begin{code}
-tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), FreeVars)
+tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
-- Returns the variables free in the decls, for unused-binding reporting
tcRnGroup decls
= do { showLIE (text "LIE at start of tcRnGroup" <+> ppr decls) ;
-- Rename the declarations
- (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
+ (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
setGblEnv tcg_env $ do {
-- Typecheck the declarations
tc_envs <- tcTopSrcDecls rn_decls ;
showLIE (text "LIE at end of tcRnGroup" <+> ppr decls) ;
- return (tc_envs, src_fvs)
+ return (tc_envs, src_dus)
}}
------------------------------------------------
-rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars)
+rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
rnTopSrcDecls group
= do { -- Bring top level binders into scope
(rdr_env, imports) <- importsFromLocalDecls group ;
failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-- Rename the source decls
- (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ;
+ (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
setGblEnv tcg_env $ do {
failIfErrsM ;
-- Import consquential imports
+ let { src_fvs = duUses src_dus } ;
rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
rnDump (ppr rn_decls) ;
rnStats rn_imp_decls ;
- return (tcg_env, rn_decls, src_fvs)
+ return (tcg_env, rn_decls, src_dus)
}}}
------------------------------------------------
ImportAvails(..), emptyImportAvails, plusImportAvails,
plusAvail, pruneAvails,
AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv,
- mkAvailEnv, lookupAvailEnv, availEnvElts, addAvail,
+ mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail,
WhereFrom(..),
-- Typechecker types
ImportAvails summarises what was imported from where, irrespective
of whether the imported htings are actually used or not
-It is used * when porcessing the export list
+It is used * when processing the export list
* when constructing usage info for the inteface file
* to identify the list of directly imported modules
for initialisation purposes
+ * when figuring out what things are really unused
\begin{code}
data ImportAvails
plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
plusAvailEnv = plusNameEnv_C plusAvail
-lookupAvailEnv = lookupNameEnv
+lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo
+lookupAvailEnv_maybe = lookupNameEnv
+
+lookupAvailEnv :: AvailEnv -> Name -> AvailInfo
+lookupAvailEnv env n = case lookupNameEnv env n of
+ Just avail -> avail
+ Nothing -> pprPanic "lookupAvailEnv" (ppr n)
availEnvElts = nameEnvElts
import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId )
import Var ( TyVar )
import Name ( Name )
-import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc,
- mkGenOcc1, mkGenOcc2, setOccNameSpace )
+import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 )
import Outputable
import TyCon ( TyCon, DataConDetails(..), visibleDataCons,
tyConTyVars, tyConName )
isTauTy, isSigmaTy,
tcSplitAppTy_maybe, tcSplitTyConApp_maybe,
tcGetTyVar_maybe, tcGetTyVar,
- mkTyConApp, mkFunTy, tyVarsOfType, mkPhiTy,
+ mkFunTy, tyVarsOfType, mkPhiTy,
typeKind, tcSplitFunTy_maybe, mkForAllTys,
isHoleTyVar, isSkolemTyVar, isUserTyVar,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
import Inst ( newDicts, instToId, tcInstCall )
import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult, newKindVar,
newTyVarTy, newTyVarTys, newOpenTypeKind, newHoleTyVarTy,
- zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar )
+ zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV )
import TcSimplify ( tcSimplifyCheck )
import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy )
-import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, findGlobals )
+import TcEnv ( tcGetGlobalTyVars, findGlobals )
import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity )
import PprType ( pprType )
-import Id ( Id, mkSysLocal, idType )
+import Id ( Id, mkSysLocal )
import Var ( Var, varName, tyVarKind )
import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems )
import VarEnv
-import Name ( isSystemName, getSrcLoc )
+import Name ( isSystemName )
import ErrUtils ( Message )
import BasicTypes ( Boxity, Arity, isBoxed )
import Util ( equalLength, notNull )
projects / ghc-hetmet.git / commitdiff