From: panne Date: Tue, 22 Feb 2000 15:48:03 +0000 (+0000) Subject: [project @ 2000-02-22 15:47:56 by panne] X-Git-Tag: Approximately_9120_patches~5112 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b78eb7be33564199dff5b03a452ea5d3b707f34d;p=ghc-hetmet.git [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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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