[project @ 2000-02-22 15:47:56 by panne]

Load deprecations from interface files into a deprecation environment
which maps Names to RenamedDeprecations. This map is not used yet, but
very soon it will...

This commit fixes a bug related to implicit parameters, too:
Previously, an interface file containing the name "with" could not be
read by the interface parser. This broke Malcolm's HaXml 0.9 (released
today). Remember Sven's glaexts-commandment (Jeffrey? :-) : Always
keep Lex.lhs's ghcExtensionKeywordsFM and ParseIface.y's var_fs
production in synch!

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 13ace2b..aef425f 100644 (file)
--- 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 32085d4..7fb5442 100644 (file)
--- 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 6858e9e..9dacbee 100644 (file)
--- 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 b4bb690..0f47641 100644 (file)
--- 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 7e3cef7..d30ef40 100644 (file)
--- 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 fbf8df1..aaeee9b 100644 (file)
--- 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 86feb4c..bea5bb2 100644 (file)
--- 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