diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 13ace2b0553f4314fa386d4fbd929590c4a41e5c..aef425f41e532a96c76784373978a4265fcdfc3b 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -280,6 +280,7 @@ haskellKeywordsFM = listToUFM $
( "_scc_", ITscc )
]
+-- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP)
ghcExtensionKeywordsFM = listToUFM $
map (\ (x,y) -> (_PK_ x,y))
[ ( "forall", ITforall ),
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 32085d4730bc761bdc89c0fa8f307ff1ca3253fb..7fb54425be2891a89f4a861814054066e4c03e20 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -36,6 +36,7 @@ module RdrHsSyn (
RdrNameTyClDecl,
RdrNameRuleDecl,
RdrNameRuleBndr,
+ RdrNameDeprecation,
RdrNameHsRecordBinds,
RdrBinding(..),
@@ -111,6 +112,7 @@ type RdrNameStmt = Stmt RdrName RdrNamePat
type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat
type RdrNameRuleBndr = RuleBndr RdrName
type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat
+type RdrNameDeprecation = Deprecation RdrName
type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 6858e9e07ec5933b23dac9f6791360c6ede3e57b..9dacbee5f37460d25a9ef8f8d4d1419d6c9813ac 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -79,6 +79,7 @@ import Ratio ( (%) )
'label' { ITlabel }
'dynamic' { ITdynamic }
'unsafe' { ITunsafe }
+ 'with' { ITwith }
'__interface' { ITinterface } -- interface keywords
'__export' { IT__export }
@@ -331,7 +332,7 @@ pragma : src_loc PRAGMA { parseIface $2 PState{ bol = 0#, atbol = 1#,
-----------------------------------------------------------------------------
-rules_and_deprecs :: { ([RdrNameRuleDecl], [(Maybe FAST_STRING, FAST_STRING)]) }
+rules_and_deprecs :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
rules_and_deprecs : {- empty -} { ([], []) }
| rules_and_deprecs rule_or_deprec
{ let
@@ -342,7 +343,7 @@ rules_and_deprecs : {- empty -} { ([], []) }
in append2 $1 $2
}
-rule_or_deprec :: { ([RdrNameRuleDecl], [(Maybe FAST_STRING, FAST_STRING)]) }
+rule_or_deprec :: { ([RdrNameRuleDecl], [RdrNameDeprecation]) }
rule_or_deprec : pragma { case $1 of
POk _ (PRules rules) -> (rules,[])
POk _ (PDeprecs deprecs) -> ([],deprecs)
@@ -364,17 +365,17 @@ rule_forall : '__forall' '{' core_bndrs '}' { $3 }
-----------------------------------------------------------------------------
-deprecs :: { [(Maybe FAST_STRING, FAST_STRING)] }
+deprecs :: { [RdrNameDeprecation] }
deprecs : {- empty -} { [] }
| deprecs deprec ';' { $2 : $1 }
-deprec :: { (Maybe FAST_STRING, FAST_STRING) }
-deprec : STRING { (Nothing, $1) }
- | deprec_name STRING { (Just $1, $2) }
+deprec :: { RdrNameDeprecation }
+deprec : STRING { DeprecMod $1 }
+ | deprec_name STRING { DeprecName $1 $2 }
-deprec_name :: { FAST_STRING }
- : var_fs { $1 }
- | tc_fs { $1 }
+deprec_name :: { RdrName }
+ : var_name { $1 }
+ | tc_name { $1 }
-----------------------------------------------------------------------------
@@ -510,6 +511,7 @@ var_fs :: { EncodedFS }
| 'label' { SLIT("label") }
| 'dynamic' { SLIT("dynamic") }
| 'unsafe' { SLIT("unsafe") }
+ | 'with' { SLIT("with") }
qvar_fs :: { (EncodedFS, EncodedFS) }
: QVARID { $1 }
@@ -853,7 +855,7 @@ data IfaceStuff = PIface EncodedFS{-.hi module name-} ParsedIface
| PIdInfo [HsIdInfo RdrName]
| PType RdrNameHsType
| PRules [RdrNameRuleDecl]
- | PDeprecs [(Maybe FAST_STRING, FAST_STRING)]
+ | PDeprecs [RdrNameDeprecation]
mkConDecl name (ex_tvs, ex_ctxt) details loc = ConDecl name ex_tvs ex_ctxt details loc
}
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index b4bb690fff4490659f78dee519ab0d623a9dcd30..0f47641c90b63a5924dbea7ea2c02b5acdccb411 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -57,6 +57,7 @@ import Maybes ( mapMaybe )
%*********************************************************
\begin{code}
+newImportedGlobalName :: ModuleName -> OccName -> Module -> RnM d Name
newImportedGlobalName mod_name occ mod
= getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) ->
let
@@ -94,6 +95,7 @@ mkImportedGlobalName mod_name occ
= lookupModuleRn mod_name `thenRn` \ mod ->
newImportedGlobalName mod_name occ mod --(mkVanillaModule mod_name)
+mkImportedGlobalFromRdrName :: RdrName -> RnM d Name
mkImportedGlobalFromRdrName rdr_name
| isQual rdr_name
= mkImportedGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 7e3cef7a0c814fc15c3f7929a0db344c96cdd248..d30ef40cacae55c73db5e178f9e63b7c44b971c6 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -45,6 +45,7 @@ type RenamedRecordBinds = HsRecordBinds Name RenamedPat
type RenamedSig = Sig Name
type RenamedStmt = Stmt Name RenamedPat
type RenamedFixitySig = FixitySig Name
+type RenamedDeprecation = Deprecation Name
type RenamedClassOpPragmas = ClassOpPragmas Name
type RenamedClassPragmas = ClassPragmas Name
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index fbf8df1ea780406423afc191a63cf07ddc4e257e..aaeee9b831c63dce8ae470a444902017381f5efe 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -24,11 +24,11 @@ import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
ForeignDecl(..), ForKind(..), isDynamic,
FixitySig(..), RuleDecl(..),
- isClassOpSig
+ isClassOpSig, Deprecation(..)
)
import BasicTypes ( Version, NewOrData(..), defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl,
- extractHsTyRdrNames
+ extractHsTyRdrNames, RdrNameDeprecation
)
import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
lookupOccRn, lookupImplicitOccRn,
@@ -37,7 +37,7 @@ import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdr
FreeVars, emptyFVs
)
import RnMonad
-import RnHsSyn ( RenamedHsDecl )
+import RnHsSyn ( RenamedHsDecl, RenamedDeprecation )
import ParseIface ( parseIface, IfaceStuff(..) )
import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, listToFM,
@@ -148,13 +148,16 @@ loadInterface doc_str mod_name from
let
rd_decls = pi_decls iface
in
- foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- (if (opt_IgnoreIfacePragmas)
+ foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
+ foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
+ (if opt_IgnoreIfacePragmas
then returnRn emptyBag
- else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules ->
- foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
- mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
+ else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules ->
+ (if opt_IgnoreIfacePragmas
+ then returnRn emptyNameEnv
+ else foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface)) `thenRn` \ new_deprecs ->
+ foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
+ mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s ->
let
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
@@ -170,8 +173,9 @@ loadInterface doc_str mod_name from
new_ifaces = ifaces { iImpModInfo = mod_map2,
iDecls = new_decls,
iFixes = new_fixities,
+ iInsts = new_insts,
iRules = new_rules,
- iInsts = new_insts }
+ iDeprecs = new_deprecs }
in
setIfacesRn new_ifaces `thenRn_`
returnRn (mod, new_ifaces)
@@ -336,6 +340,16 @@ loadRule mod rules decl@(IfaceRuleDecl var body src_loc)
= setModuleRn (moduleName mod) $
mkImportedGlobalFromRdrName var `thenRn` \ var_name ->
returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules)
+
+loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv
+loadDeprec mod deprec_env (DeprecMod 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)
+ = 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))
\end{code}
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index 86feb4c51f1e007ab8e3691c146de682f69288d8..bea5bb293c43746658461a194c3e30daa83274bc 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -31,7 +31,7 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO )
import HsSyn
import RdrHsSyn
-import RnHsSyn ( RenamedFixitySig )
+import RnHsSyn ( RenamedFixitySig, RenamedDeprecation )
import BasicTypes ( Version )
import SrcLoc ( noSrcLoc )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine,
@@ -193,6 +193,9 @@ type FixityEnv = NameEnv RenamedFixitySig
-- We keep the whole fixity sig so that we
-- can report line-number info when there is a duplicate
-- fixity declaration
+
+--------------------------------
+type DeprecationEnv = NameEnv RenamedDeprecation
\end{code}
\begin{code}
@@ -284,7 +287,7 @@ data ParsedIface
pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions
pi_insts :: [RdrNameInstDecl], -- Local instance declarations
pi_rules :: [RdrNameRuleDecl], -- Rules
- pi_deprecs :: [(Maybe FAST_STRING, FAST_STRING)] -- Deprecations, the type is currently only a hack
+ pi_deprecs :: [RdrNameDeprecation] -- Deprecations
}
data InterfaceDetails
@@ -330,8 +333,10 @@ data Ifaces = Ifaces {
-- Each is 'gated' by the names that must be available before
-- this instance decl is needed.
- iRules :: Bag GatedDecl
+ iRules :: Bag GatedDecl,
-- Ditto transformation rules
+
+ iDeprecs :: DeprecationEnv
}
type GatedDecl = (NameSet, (Module, RdrNameHsDecl))
@@ -419,7 +424,8 @@ emptyIfaces = Ifaces { iImpModInfo = emptyFM,
-- and we don't want thereby to try to suck it in!
iVSlurp = [],
iInsts = emptyBag,
- iRules = emptyBag
+ iRules = emptyBag,
+ iDeprecs = emptyNameEnv
}
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly