From 06619533d2e402ec10eaec3752c76d310565d0fc Mon Sep 17 00:00:00 2001 From: panne Date: Tue, 15 Feb 2000 22:18:54 +0000 Subject: [PATCH] [project @ 2000-02-15 22:18:16 by panne] First steps towards DEPRECATED before Rosebank (12yrs) takes its toll. Nothing very functional yet, but at least hsc can be compiled and it still compiles the Prelude. Parsing the pragma turned out to be a little bit more complicated than expected, here the comment from Parser.y: The place for module deprecation is really too restrictive, but if it was allowed at its natural place just before 'module', we get an ugly s/r conflict with the second alternative. Another solution would be the introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, either, and DEPRECATED is only expected to be used by people who really know what they are doing. :-) Net result: Module deprecation is allowed exactly behind the module's name and nowhere else. I probably have to think a little bit more about this some day... --- ghc/compiler/hsSyn/HsBinds.lhs | 14 +++++++++-- ghc/compiler/hsSyn/HsSyn.lhs | 6 ++++- ghc/compiler/main/Main.lhs | 4 +-- ghc/compiler/parser/Lex.lhs | 6 ++++- ghc/compiler/parser/Parser.y | 47 ++++++++++++++++++++++++++++++----- ghc/compiler/rename/Rename.lhs | 5 ++-- ghc/compiler/rename/RnNames.lhs | 2 +- ghc/compiler/typecheck/TcModule.lhs | 2 +- 8 files changed, 70 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 822b4a2..049baac 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -257,8 +257,13 @@ data Sig name | FixSig (FixitySig name) -- Fixity declaration + | DeprecSig name -- DEPRECATED + DeprecTxt + data FixitySig name = FixitySig name Fixity SrcLoc + +type DeprecTxt = FAST_STRING -- reason/explanation for deprecation \end{code} \begin{code} @@ -273,6 +278,7 @@ sigsForMe f sigs sig_for_me (NoInlineSig n _ _) = f n sig_for_me (SpecInstSig _ _) = False sig_for_me (FixSig (FixitySig n _ _)) = f n + sig_for_me (DeprecSig n _) = f n isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True @@ -288,6 +294,7 @@ isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _) = True isPragSig (NoInlineSig _ _ _) = True isPragSig (SpecInstSig _ _) = True +isPragSig (DeprecSig _ _) = True isPragSig other = False \end{code} @@ -311,16 +318,19 @@ ppr_sig (SpecSig var ty _) ] ppr_sig (InlineSig var phase _) - = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"] + = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"] ppr_sig (NoInlineSig var phase _) - = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"] + = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"] ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (DeprecSig n txt) + = hsep [text "{-# DEPRECATED", ppr n, ppr txt, text "#-}"] + ppr_phase Nothing = empty ppr_phase (Just n) = int n \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 62f8333..3c73d8d 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -62,6 +62,7 @@ data HsModule name pat -- 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} @@ -70,8 +71,11 @@ instance (Outputable name, Outputable pat) => Outputable (HsModule name pat) where ppr (HsModule name iface_version exports imports - decls src_loc) + decls deprec src_loc) = vcat [ + case deprec of + Nothing -> empty + Just dt -> hsep [ptext SLIT("{-# DEPRECATED"), ppr dt, ptext SLIT("#-}")], case exports of Nothing -> hsep [ptext SLIT("module"), pprModuleName name, ptext SLIT("where")] Just es -> vcat [ diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index dc2a2cc..9702944 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -74,7 +74,7 @@ parseModule = do ghcExit 1 return (error "parseModule") -- just to get the types right - POk _ m@(HsModule mod _ _ _ _ _) -> + POk _ m@(HsModule mod _ _ _ _ _ _) -> return (mod, m) where glaexts | opt_GlasgowExts = 1# @@ -222,7 +222,7 @@ doIt (core_cmds, stg_cmds) then \ what -> hPutStr stderr ("*** "++what++":\n") else \ what -> return () -ppSourceStats short (HsModule name version exports imports decls src_loc) +ppSourceStats short (HsModule name version exports imports decls _ src_loc) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 7d74bed..13ace2b 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -158,6 +158,7 @@ data Token | ITunfold InlinePragInfo | ITstrict ([Demand], Bool) | ITrules + | ITdeprecated | ITcprinfo (CprInfo) | IT__scc | ITsccAllCafs @@ -167,6 +168,7 @@ data Token | ITinline_prag | ITnoinline_prag | ITrules_prag + | ITdeprecated_prag | ITline_prag | ITclose_prag @@ -244,7 +246,8 @@ pragmaKeywordsFM = listToUFM $ ( "NOTINLINE", ITnoinline_prag ), ( "LINE", ITline_prag ), ( "RULES", ITrules_prag ), - ( "RULEZ", ITrules_prag ) -- american spelling :-) + ( "RULEZ", ITrules_prag ), -- american spelling :-) + ( "DEPRECATED", ITdeprecated_prag ) ] haskellKeywordsFM = listToUFM $ @@ -318,6 +321,7 @@ ghcExtensionKeywordsFM = listToUFM $ ("__P", ITspecialise), ("__C", ITnocaf), ("__R", ITrules), + ("__D", ITdeprecated), ("__U", ITunfold NoInlinePragInfo), ("__ccall", ITccall (False, False, False)), diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index a94edff..88ba099 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.20 2000/02/09 18:32:10 lewie Exp $ +$Id: Parser.y,v 1.21 2000/02/15 22:18:34 panne Exp $ Haskell grammar. @@ -36,6 +36,7 @@ import GlaExts ----------------------------------------------------------------------------- Conflicts: 14 shift/reduce (note: it's currently 21 -- JRL, 31/1/2000) + (note2: it' currently 36, but not because of me -- SUP, 15/2/2000 :-) 8 for abiguity in 'if x then y else z + 1' (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) @@ -107,6 +108,7 @@ Conflicts: 14 shift/reduce '{-# INLINE' { ITinline_prag } '{-# NOINLINE' { ITnoinline_prag } '{-# RULES' { ITrules_prag } + '{-# DEPRECATED' { ITdeprecated_prag } '#-}' { ITclose_prag } {- @@ -189,7 +191,7 @@ Conflicts: 14 shift/reduce PRIMSTRING { ITprimstring $$ } PRIMINTEGER { ITprimint $$ } PRIMFLOAT { ITprimfloat $$ } - PRIMDOUBLE { ITprimdouble $$ } + PRIMDOUBLE { ITprimdouble $$ } CLITLIT { ITlitlit $$ } UNKNOWN { ITunknown $$ } @@ -203,11 +205,22 @@ Conflicts: 14 shift/reduce ----------------------------------------------------------------------------- -- Module Header +-- The place for module deprecation is really too restrictive, but if it +-- was allowed at its natural place just before 'module', we get an ugly +-- s/r conflict with the second alternative. Another solution would be the +-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, +-- either, and DEPRECATED is only expected to be used by people who really +-- know what they are doing. :-) + module :: { RdrNameHsModule } - : srcloc 'module' modid maybeexports 'where' body - { HsModule $3 Nothing $4 (fst $6) (snd $6) $1 } - | srcloc body - { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) $1 } + : srcloc 'module' modid maybemoddeprec maybeexports 'where' body + { HsModule $3 Nothing $5 (fst $7) (snd $7) $4 $1 } + | srcloc body + { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 } + +maybemoddeprec :: { Maybe FAST_STRING } + : '{-# DEPRECATED' STRING '#-}' { Just $2 } + | {- empty -} { Nothing } body :: { ([RdrNameImportDecl], [RdrNameHsDecl]) } : '{' top '}' { $2 } @@ -379,6 +392,7 @@ decl :: { RdrBinding } | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' { RdrSig (SpecInstSig $4 $2) } | '{-# RULES' rules '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } opt_phase :: { Maybe Int } : INTEGER { Just (fromInteger $1) } @@ -458,6 +472,27 @@ rule_var :: { RdrNameRuleBndr } | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } ----------------------------------------------------------------------------- +-- Deprecations + +deprecations :: { RdrBinding } + : deprecations ';' deprecation { $1 `RdrAndBindings` $3 } + | deprecations ';' { $1 } + | deprecation { $1 } + | {- empty -} { RdrNullBind } + +deprecation :: { RdrBinding } + : deprecated_names STRING + { foldr1 RdrAndBindings [ RdrSig (DeprecSig n $2) | n <- $1 ] } + +deprecated_names :: { [RdrName] } + : deprecated_names ',' deprecated_name { $3 : $1 } + | deprecated_name { [$1] } + +deprecated_name :: { RdrName } + : var { $1 } + | tycon { $1 } + +----------------------------------------------------------------------------- -- Foreign import/export callconv :: { Int } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index f95b222..21e8dd9 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -69,7 +69,7 @@ renameModule :: UniqSupply , [ModuleName] -- Imported modules; for profiling )) -renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc) +renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) >>= @@ -90,7 +90,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc \begin{code} -rename this_mod@(HsModule mod_name vers _ imports local_decls loc) +rename this_mod@(HsModule mod_name vers _ imports local_decls _ loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -146,6 +146,7 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls loc) renamed_module = HsModule mod_name vers trashed_exports trashed_imports rn_all_decls + Nothing loc in rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 142b36c..832c925 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -69,7 +69,7 @@ getGlobalNames :: RdrNameHsModule )) -- Nothing => no need to recompile -getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) +getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) -> diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index c3b6dc2..28a6bd4 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -131,7 +131,7 @@ tcModule :: RnNameSupply -- for renaming derivings -> TcM s TcResults -- output tcModule rn_name_supply fixities - (HsModule mod_name verion exports imports decls src_loc) + (HsModule mod_name verion exports imports decls _ src_loc) = tcAddSrcLoc src_loc $ -- record where we're starting fixTc (\ ~(unf_env ,_) -> -- 1.7.10.4