-- friends:
import HsTypes ( HsType )
+import HsImpExp ( IE(..), ieName )
import CoreSyn ( CoreExpr )
import PprCore () -- Instances for Outputable
data FixitySig name = FixitySig name Fixity SrcLoc
-data Deprecation name
- = DeprecMod DeprecTxt -- deprecation of a whole module
- | DeprecName name DeprecTxt -- deprecation of a single name
+-- We use exported entities for things to deprecate. Cunning trick (hack?):
+-- `IEModuleContents undefined' is used for module deprecation.
+data Deprecation name = Deprecation (IE name) DeprecTxt
type DeprecTxt = FAST_STRING -- reason/explanation for deprecation
\end{code}
sigsForMe f sigs
= filter sig_for_me sigs
where
- sig_for_me (Sig n _ _) = f n
- sig_for_me (ClassOpSig n _ _ _ _) = f n
- sig_for_me (SpecSig n _ _) = f n
- sig_for_me (InlineSig n _ _) = f n
- sig_for_me (NoInlineSig n _ _) = f n
- sig_for_me (SpecInstSig _ _) = False
- sig_for_me (FixSig (FixitySig n _ _)) = f n
- sig_for_me (DeprecSig (DeprecMod _) _) = False
- sig_for_me (DeprecSig (DeprecName n _) _) = f n
+ sig_for_me (Sig n _ _) = f n
+ sig_for_me (ClassOpSig n _ _ _ _) = f n
+ sig_for_me (SpecSig n _ _) = f n
+ sig_for_me (InlineSig n _ _) = f n
+ sig_for_me (NoInlineSig n _ _) = f n
+ sig_for_me (SpecInstSig _ _) = False
+ sig_for_me (FixSig (FixitySig n _ _)) = f n
+ sig_for_me
+ (DeprecSig (Deprecation (IEModuleContents _) _) _) = False
+ sig_for_me
+ (DeprecSig (Deprecation d _) _) = f (ieName d)
isFixitySig :: Sig name -> Bool
isFixitySig (FixSig _) = True
instance (Outputable name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
-instance Outputable name => Outputable (FixitySig name) where
- ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
-
-instance Outputable name => Outputable (Deprecation name) where
- ppr (DeprecMod txt)
- = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
- ppr (DeprecName n txt)
- = hsep [text "{-# DEPRECATED", ppr n, doubleQuotes (ppr txt), text "#-}"]
-
+ppr_sig :: Outputable name => Sig name -> SDoc
ppr_sig (Sig var ty _)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
ppr_sig (DeprecSig deprec _) = ppr deprec
-ppr_phase Nothing = empty
+instance Outputable name => Outputable (FixitySig name) where
+ ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
+
+instance Outputable name => Outputable (Deprecation name) where
+ ppr (Deprecation (IEModuleContents _) txt)
+ = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"]
+ ppr (Deprecation thing txt)
+ = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
+
+ppr_phase :: Maybe Int -> SDoc
+ppr_phase Nothing = empty
ppr_phase (Just n) = int n
\end{code}
\begin{code}
data HsModule name pat
= HsModule
- ModuleName -- module name
- (Maybe Version) -- source interface version number
- (Maybe [IE name]) -- export list; Nothing => export everything
- -- Just [] => export *nothing* (???)
- -- Just [...] => as you would expect...
- [ImportDecl name] -- We snaffle interesting stuff out of the
- -- imported interfaces early on, adding that
- -- info to TyDecls/etc; so this list is
- -- often empty, downstream.
- [HsDecl name pat] -- Type, class, value, and interface signature decls
- (Maybe (Deprecation name)) -- reason/explanation for deprecation of this module
+ ModuleName -- module name
+ (Maybe Version) -- source interface version number
+ (Maybe [IE name]) -- export list; Nothing => export everything
+ -- Just [] => export *nothing* (???)
+ -- Just [...] => as you would expect...
+ [ImportDecl name] -- We snaffle interesting stuff out of the
+ -- imported interfaces early on, adding that
+ -- info to TyDecls/etc; so this list is
+ -- often empty, downstream.
+ [HsDecl name pat] -- Type, class, value, and interface signature decls
+ (Maybe DeprecTxt) -- reason/explanation for deprecation of this module
SrcLoc
\end{code}
opt_WarnUnusedBinds,
opt_WarnUnusedImports,
opt_WarnUnusedMatches,
+ opt_WarnDeprecations,
-- profiling opts
opt_AutoSccsOnAllToplevs,
opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds")
opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports")
opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches")
+opt_WarnDeprecations = lookUp SLIT("-fwarn-deprecations")
-- profiling opts
opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs")
ptext SLIT("##-}")
])
where
- pprIfaceDeprec (DeprecMod txt) = doubleQuotes (ppr txt)
- pprIfaceDeprec (DeprecName n txt) = ppr n <+> doubleQuotes (ppr txt)
+ -- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
+ pprIfaceDeprec (Deprecation (IEModuleContents _) txt) = doubleQuotes (ppr txt)
+ pprIfaceDeprec (Deprecation (IEVar n) txt) = ppr n <+> doubleQuotes (ppr txt)
\end{code}
%************************************************************************
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.23 2000/02/20 17:51:45 panne Exp $
+$Id: Parser.y,v 1.24 2000/02/25 14:55:42 panne Exp $
Haskell grammar.
| srcloc body
{ HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 }
-maybemoddeprec :: { Maybe (Deprecation RdrName) }
- : '{-# DEPRECATED' STRING '#-}' { Just (DeprecMod $2) }
+maybemoddeprec :: { Maybe DeprecTxt }
+ : '{-# DEPRECATED' STRING '#-}' { Just $2 }
| {- empty -} { Nothing }
body :: { ([RdrNameImportDecl], [RdrNameHsDecl]) }
| deprecation { $1 }
| {- empty -} { RdrNullBind }
+-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { RdrBinding }
- : deprecated_names STRING
- { foldr1 RdrAndBindings [ RdrSig (DeprecSig (DeprecName n $2) l) | (l,n) <- $1 ] }
-
-deprecated_names :: { [(SrcLoc,RdrName)] }
- : deprecated_names ',' deprecated_name { $3 : $1 }
- | deprecated_name { [$1] }
-
-deprecated_name :: { (SrcLoc,RdrName) }
- : srcloc var { ($1, $2) }
- | srcloc tycon { ($1, $2) }
+ : srcloc exportlist STRING
+ { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] }
-----------------------------------------------------------------------------
-- Foreign import/export
| deprecs deprec ';' { $2 : $1 }
deprec :: { RdrNameDeprecation }
-deprec : STRING { DeprecMod $1 }
- | deprec_name STRING { DeprecName $1 $2 }
+deprec : STRING { Deprecation (IEModuleContents undefined) $1 }
+ | deprec_name STRING { Deprecation $1 $2 }
-deprec_name :: { RdrName }
- : var_name { $1 }
- | tc_name { $1 }
+-- SUP: TEMPORARY HACK
+deprec_name :: { RdrNameIE }
+ : var_name { IEVar $1 }
-----------------------------------------------------------------------------
)
import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace,
- opt_D_dump_rn, opt_D_dump_rn_stats,
- opt_WarnUnusedBinds, opt_WarnUnusedImports
+ opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations
)
import RnMonad
import RnNames ( getGlobalNames )
import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions,
getImportedRules, loadHomeInterface, getSlurped, removeContext
)
-import RnEnv ( availName, availNames, availsToNameSet,
- warnUnusedImports, warnUnusedLocalBinds, mapFvRn, lookupImplicitOccRn,
+import RnEnv ( availName, availsToNameSet,
+ warnUnusedImports, warnUnusedLocalBinds, lookupImplicitOccRn,
FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
)
-import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )
-import Name ( Name, isLocallyDefined,
- NamedThing(..), ImportReason(..), Provenance(..),
- pprOccName, nameOccName, nameUnique,
- getNameProvenance, isUserImportedExplicitlyName,
+import Module ( Module, ModuleName, mkSearchPath, mkThisModule )
+import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
+ nameOccName, nameUnique, isUserImportedExplicitlyName,
maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
)
+import OccName ( occNameFlavour )
import Id ( idType )
-import DataCon ( dataConTyCon, dataConType )
-import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
-import RdrName ( RdrName )
+import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
import PrelMods ( mAIN_Name, pREL_MAIN_Name )
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit )
import BasicTypes ( NewOrData(..) )
import Bag ( isEmptyBag, bagToList )
-import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM )
+import FiniteMap ( eltsFM )
import UniqSupply ( UniqSupply )
import UniqFM ( lookupUFM )
-import Util ( equivClasses )
import Maybes ( maybeToBool )
-import SrcLoc ( mkBuiltinSrcLoc )
import Outputable
\end{code}
\begin{code}
+rename :: RdrNameHsModule
+ -> RnMG (Maybe (Module, RenamedHsModule, InterfaceDetails, RnNameSupply, [ModuleName]), IO ())
rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff ->
-- COLLECT ALL DEPRECATIONS
deprec_sigs = [ ds | ValD bnds <- rn_local_decls, ds <- collectDeprecs bnds ]
-
- (rn_mod_deprec, deprecs) = case mod_deprec of
- Nothing -> (Nothing, deprec_sigs)
- Just (DeprecMod t) -> let dm = DeprecMod t in (Just dm, dm:deprec_sigs)
-
- collectDeprecs EmptyBinds = []
- collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y
- collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ]
+ deprecs = case mod_deprec of
+ Nothing -> deprec_sigs
+ Just txt -> Deprecation (IEModuleContents undefined) txt : deprec_sigs
in
-- EXIT IF ERRORS FOUND
renamed_module = HsModule mod_name vers
trashed_exports trashed_imports
rn_all_decls
- rn_mod_deprec
+ mod_deprec
loc
in
rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action ->
where
trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
trashed_imports = {-trace "rnSource:trashed_imports"-} []
+
+ collectDeprecs EmptyBinds = []
+ collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y
+ collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ]
\end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't
%*********************************************************
\begin{code}
+reportUnusedNames :: GlobalRdrEnv -> NameEnv AvailInfo -> ExportEnv -> NameSet -> RnM d ()
reportUnusedNames gbl_env avail_env (ExportEnv export_avails _ _) mentioned_names
= let
used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
-- Filter out the ones only defined implicitly
bad_locals = [n | n <- defined_but_not_used, isLocallyDefined n]
bad_imps = [n | n <- defined_but_not_used, isUserImportedExplicitlyName n]
+
+ non_locally_used = [ n | n <- nameSetToList really_used_names, not (isLocallyDefined n) ]
+ deprec_used deprec_env = [ (n,txt) | n <- non_locally_used, Just txt <- [lookupNameEnv deprec_env n] ]
in
- warnUnusedLocalBinds bad_locals `thenRn_`
+ traceRn (text "really used and non-locally defined" <> colon <+>
+ nest 4 (fsep (punctuate comma [ text (occNameFlavour (nameOccName n)) <+> ppr n
+ | n <- non_locally_used]))) `thenRn_`
+ getIfacesRn `thenRn` \ ifaces ->
+ if opt_WarnDeprecations
+ then mapRn_ warnDeprec (deprec_used (iDeprecs ifaces))
+ else returnRn () `thenRn_`
+ warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imps
+warnDeprec :: (Name, DeprecTxt) -> RnM d ()
+warnDeprec (name, txt)
+ = pushSrcLocRn (getSrcLoc name) $
+ addWarnRn $
+ sep [ text "Using deprecated entity" <+> ppr name <> colon, nest 4 (ppr txt) ]
+
rnDump :: [RenamedHsDecl] -- Renamed imported decls
-> [RenamedHsDecl] -- Renamed local decls
-> RnMG (IO ())
lookup_occ_nm v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v)
-renameSig lookup_occ_nm (DeprecSig (DeprecName v txt) src_loc)
+-- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
+renameSig lookup_occ_nm (DeprecSig (Deprecation (IEVar v) txt) src_loc)
= pushSrcLocRn src_loc $
lookup_occ_nm v `thenRn` \ new_v ->
- returnRn (DeprecSig (DeprecName new_v txt) src_loc, unitFV new_v)
+ returnRn (DeprecSig (Deprecation (IEVar new_v) txt) src_loc, unitFV new_v)
renameSig lookup_occ_nm (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
Checking for distinct signatures; oh, so boring
+
\begin{code}
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
-cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
-cmp_sig (DeprecSig (DeprecName n1 _) _) (DeprecSig (DeprecName n2 _) _) = n1 `compare` n2
-cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
-cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
-cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
+cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
+-- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
+cmp_sig (DeprecSig (Deprecation (IEVar n1) _) _)
+ (DeprecSig (Deprecation (IEVar n2) _) _) = n1 `compare` n2
+cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2
+cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
+cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
+cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules)
+-- SUP: TEMPORARY HACK, ignoring module deprecations and constructors for now
loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv
-loadDeprec mod deprec_env (DeprecMod txt)
+loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt)
= traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_`
returnRn deprec_env
-loadDeprec mod deprec_env (DeprecName rdr_name txt)
+loadDeprec mod deprec_env (Deprecation (IEVar rdr_name) txt)
= setModuleRn (moduleName mod) $
mkImportedGlobalFromRdrName rdr_name `thenRn` \ name ->
traceRn (text "loaded deprecation for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
- returnRn (addToNameEnv deprec_env name (DeprecName name txt))
+ returnRn (addToNameEnv deprec_env name txt)
\end{code}
-- fixity declaration
--------------------------------
-type DeprecationEnv = NameEnv RenamedDeprecation
+type DeprecationEnv = NameEnv DeprecTxt
\end{code}
\begin{code}
-fwarn-overlapping-patterns
-fwarn-missing-methods
+ -fwarn-missing-fields
+ -fwarn-deprecations
-fwarn-duplicate-exports
these are turned off by -Wnot.
@StandardWarnings = ('-fwarn-overlapping-patterns',
'-fwarn-missing-methods',
'-fwarn-missing-fields',
+ '-fwarn-deprecations',
'-fwarn-duplicate-exports');
@MinusWOpts = (@StandardWarnings,
'-fwarn-unused-binds',
projects / ghc-hetmet.git / commitdiff