From: panne Date: Sun, 20 Feb 2000 17:51:58 +0000 (+0000) Subject: [project @ 2000-02-20 17:51:30 by panne] X-Git-Tag: Approximately_9120_patches~5118 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6cce4a58fb206f16db579fded00fd0a7090543ae;p=ghc-hetmet.git [project @ 2000-02-20 17:51:30 by panne] Get deprecation info out of the renamer again --- diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index dea4faf..4763425 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -255,15 +255,18 @@ data Sig name -- current instance decl SrcLoc - | FixSig (FixitySig name) -- Fixity declaration + | FixSig (FixitySig name) -- Fixity declaration - | DeprecSig name -- DEPRECATED - DeprecTxt + | DeprecSig (Deprecation name) -- DEPRECATED SrcLoc 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 + type DeprecTxt = FAST_STRING -- reason/explanation for deprecation \end{code} @@ -272,14 +275,15 @@ sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name] 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 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 (DeprecMod _) _) = False + sig_for_me (DeprecSig (DeprecName n _) _) = f n isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True @@ -295,7 +299,7 @@ isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _) = True isPragSig (NoInlineSig _ _ _) = True isPragSig (SpecInstSig _ _) = True -isPragSig (DeprecSig _ _ _) = True +isPragSig (DeprecSig _ _) = True isPragSig other = False \end{code} @@ -306,6 +310,11 @@ instance (Outputable name) => Outputable (Sig name) where 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 (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] @@ -329,8 +338,7 @@ ppr_sig (SpecInstSig ty _) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (DeprecSig n txt _) - = hsep [text "{-# DEPRECATED", ppr n, doubleQuotes(ppr txt), text "#-}"] +ppr_sig (DeprecSig deprec _) = ppr deprec ppr_phase Nothing = empty ppr_phase (Just n) = int n diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 3435071..6347228 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -52,17 +52,17 @@ All we actually declare here is the top-level structure for a module. \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 DeprecTxt) -- 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 (Deprecation name)) -- reason/explanation for deprecation of this module SrcLoc \end{code} @@ -86,11 +86,7 @@ instance (Outputable name, Outputable pat) where pp_header rest = case deprec of Nothing -> pp_modname <+> rest - Just dt -> vcat [ - pp_modname, - hsep [ptext SLIT("{-# DEPRECATED"), doubleQuotes (ppr dt), ptext SLIT("#-}")], - rest - ] + Just d -> vcat [ pp_modname, ppr d, rest ] pp_modname = ptext SLIT("module") <+> pprModuleName name diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 056880e..4167f47 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -92,7 +92,7 @@ endIface :: Maybe Handle -> IO () \end{code} \begin{code} -startIface mod (has_orphans, import_usages, ExportEnv avails fixities _) +startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _) = case opt_ProduceHi of Nothing -> return Nothing ; -- not producing any .hi file diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d45e396..2f907b0 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.22 2000/02/17 14:47:26 panne Exp $ +$Id: Parser.y,v 1.23 2000/02/20 17:51:45 panne Exp $ Haskell grammar. @@ -36,7 +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 :-) + (note2: it's 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) @@ -218,8 +218,8 @@ module :: { RdrNameHsModule } | srcloc body { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 } -maybemoddeprec :: { Maybe FAST_STRING } - : '{-# DEPRECATED' STRING '#-}' { Just $2 } +maybemoddeprec :: { Maybe (Deprecation RdrName) } + : '{-# DEPRECATED' STRING '#-}' { Just (DeprecMod $2) } | {- empty -} { Nothing } body :: { ([RdrNameImportDecl], [RdrNameHsDecl]) } @@ -482,7 +482,7 @@ deprecations :: { RdrBinding } deprecation :: { RdrBinding } : deprecated_names STRING - { foldr1 RdrAndBindings [ RdrSig (DeprecSig n $2 l) | (l,n) <- $1 ] } + { foldr1 RdrAndBindings [ RdrSig (DeprecSig (DeprecName n $2) l) | (l,n) <- $1 ] } deprecated_names :: { [(SrcLoc,RdrName)] } : deprecated_names ',' deprecated_name { $3 : $1 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index c3ede2f..6f0c149 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -90,7 +90,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ l \begin{code} -rename this_mod@(HsModule mod_name vers _ imports local_decls deprec loc) +rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -120,6 +120,17 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls deprec loc) slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> let rn_all_decls = rn_local_decls ++ rn_imp_decls + + -- 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 ] in -- EXIT IF ERRORS FOUND @@ -146,13 +157,13 @@ rename this_mod@(HsModule mod_name vers _ imports local_decls deprec loc) renamed_module = HsModule mod_name vers trashed_exports trashed_imports rn_all_decls - deprec + rn_mod_deprec loc in rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> returnRn (Just (mkThisModule mod_name, renamed_module, - (has_orphans, my_usages, export_env), + (InterfaceDetails has_orphans my_usages export_env deprecs), name_supply, direct_import_mods), dump_action) where diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index defbee5..d5a7731 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -541,10 +541,10 @@ renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) lookup_occ_nm v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) -renameSig lookup_occ_nm (DeprecSig v txt src_loc) +renameSig lookup_occ_nm (DeprecSig (DeprecName v txt) src_loc) = pushSrcLocRn src_loc $ lookup_occ_nm v `thenRn` \ new_v -> - returnRn (DeprecSig new_v txt src_loc, unitFV new_v) + returnRn (DeprecSig (DeprecName new_v txt) src_loc, unitFV new_v) renameSig lookup_occ_nm (InlineSig v p src_loc) = pushSrcLocRn src_loc $ @@ -561,12 +561,12 @@ 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 n1 _ _) (DeprecSig 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 +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 _) = -- may have many specialisations for one value; -- but not ones that are exactly the same... thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) @@ -581,7 +581,7 @@ sig_tag (InlineSig n1 _ _) = ILIT(3) sig_tag (NoInlineSig n1 _ _) = ILIT(4) sig_tag (SpecInstSig _ _) = ILIT(5) sig_tag (FixSig _) = ILIT(6) -sig_tag (DeprecSig _ _ _) = ILIT(7) +sig_tag (DeprecSig _ _) = ILIT(7) sig_tag _ = panic# "tag(RnBinds)" \end{code} @@ -614,7 +614,7 @@ sig_doc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) -sig_doc (DeprecSig _ _ loc) = (SLIT("DEPRECATED pragma"), loc) +sig_doc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc) missingSigWarn var = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index fdfaccf..86feb4c 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -287,14 +287,16 @@ data ParsedIface pi_deprecs :: [(Maybe FAST_STRING, FAST_STRING)] -- Deprecations, the type is currently only a hack } -type InterfaceDetails = (WhetherHasOrphans, - VersionInfo Name, -- Version information for what this module imports - ExportEnv) -- What modules this one depends on +data InterfaceDetails + = InterfaceDetails WhetherHasOrphans + (VersionInfo Name) -- Version information for what this module imports + ExportEnv -- What modules this one depends on + [Deprecation Name] -- needed by Main to fish out the fixities assoc list. getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (_, _, ExportEnv _ fs _) = fs +getIfaceFixities (InterfaceDetails _ _ (ExportEnv _ fs _) _) = fs type RdrNamePragma = () -- Fudge for now