X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPragmas.lhs;h=013129dcff4152eafba52b13eb58f8325c21ba14;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=c8a7112a614ac8c24749abcc56a51cadcb26b630;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index c8a7112..013129d 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % %************************************************************************ %* * @@ -12,20 +12,12 @@ for values show up; ditto @SpecInstSig@ (for instances) and @SpecDataSig@ (for data types). \begin{code} -#include "HsVersions.h" - module HsPragmas where -IMP_Ubiq() - --- friends: -import HsTypes ( HsType ) +#include "HsVersions.h" --- others: import IdInfo -import SpecEnv ( SpecEnv ) -import Outputable ( Outputable(..) ) -import Pretty +import Outputable \end{code} All the pragma stuff has changed. Here are some placeholders! @@ -53,191 +45,14 @@ noClassOpPragmas = NoClassOpPragmas isNoClassOpPragmas NoClassOpPragmas = True instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = ppNil - -instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = ppNil - -instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = ppNil - -instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = ppNil -\end{code} - -========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ============== - -\begin{code} -{- COMMENTED OUT - -Certain pragmas expect to be pinned onto certain constructs. - -Pragma types may be parameterised, just as with any other -abstract-syntax type. - -For a @data@ declaration---indicates which specialisations exist. -\begin{code} -data DataPragmas name - = NoDataPragmas - | DataPragmas [[Maybe (HsType name)]] -- types to which specialised - -noDataPragmas = NoDataPragmas -isNoDataPragmas NoDataPragmas = True -\end{code} - -These are {\em general} things you can know about any value: -\begin{code} -data GenPragmas name - = NoGenPragmas - | GenPragmas (Maybe Int) -- arity (maybe) - (Maybe UpdateInfo) -- update info (maybe) - DeforestInfo -- deforest info - (ImpStrictness name) -- strictness, worker-wrapper - (ImpUnfolding name) -- unfolding (maybe) - [([Maybe (HsType name)], -- Specialisations: types to which spec'd; - Int, -- # dicts to ignore - GenPragmas name)] -- Gen info about the spec'd version - -noGenPragmas = NoGenPragmas - -isNoGenPragmas NoGenPragmas = True -isNoGenPragmas _ = False - -data ImpUnfolding name - = NoImpUnfolding - | ImpMagicUnfolding FAST_STRING -- magic "unfolding" - -- known to the compiler by "String" - | ImpUnfolding UnfoldingGuidance -- always, if you like, etc. - (UnfoldingCoreExpr name) - -data ImpStrictness name - = NoImpStrictness - | ImpStrictness Bool -- True <=> bottoming Id - [Demand] -- demand info - (GenPragmas name) -- about the *worker* -\end{code} - -For an ordinary imported function: it can have general pragmas (only). - -For a class's super-class dictionary selectors: -\begin{code} -data ClassPragmas name - = NoClassPragmas - | SuperDictPragmas [GenPragmas name] -- list mustn't be empty - -noClassPragmas = NoClassPragmas - -isNoClassPragmas NoClassPragmas = True -isNoClassPragmas _ = False -\end{code} - -For a class's method selectors: -\begin{code} -data ClassOpPragmas name - = NoClassOpPragmas - | ClassOpPragmas (GenPragmas name) -- for method selector - (GenPragmas name) -- for default method - - -noClassOpPragmas = NoClassOpPragmas - -isNoClassOpPragmas NoClassOpPragmas = True -isNoClassOpPragmas _ = False -\end{code} - -\begin{code} -data InstancePragmas name - = NoInstancePragmas - - | SimpleInstancePragma -- nothing but for the dfun itself... - (GenPragmas name) - - | ConstantInstancePragma - (GenPragmas name) -- for the "dfun" itself - [(name, GenPragmas name)] -- one per class op - - | SpecialisedInstancePragma - (GenPragmas name) -- for its "dfun" - [([Maybe (HsType name)], -- specialised instance; type... - Int, -- #dicts to ignore - InstancePragmas name)] -- (no SpecialisedInstancePragma please!) - -noInstancePragmas = NoInstancePragmas - -isNoInstancePragmas NoInstancePragmas = True -isNoInstancePragmas _ = False -\end{code} - -Some instances for printing (just for debugging, really) -\begin{code} -instance Outputable name => Outputable (ClassPragmas name) where - ppr sty NoClassPragmas = ppNil - ppr sty (SuperDictPragmas sdsel_prags) - = ppAbove (ppPStr SLIT("{-superdict pragmas-}")) - (ppr sty sdsel_prags) + ppr NoClassPragmas = empty instance Outputable name => Outputable (ClassOpPragmas name) where - ppr sty NoClassOpPragmas = ppNil - ppr sty (ClassOpPragmas op_prags defm_prags) - = ppAbove (ppCat [ppPStr SLIT("{-meth-}"), ppr sty op_prags]) - (ppCat [ppPStr SLIT("{-defm-}"), ppr sty defm_prags]) + ppr NoClassOpPragmas = empty instance Outputable name => Outputable (InstancePragmas name) where - ppr sty NoInstancePragmas = ppNil - ppr sty (SimpleInstancePragma dfun_pragmas) - = ppCat [ppPStr SLIT("{-dfun-}"), ppr sty dfun_pragmas] - ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs) - = ppAbove (ppCat [ppPStr SLIT("{-constm-}"), ppr sty dfun_pragmas]) - (ppAboves (map pp_pair name_pragma_pairs)) - where - pp_pair (n, prags) - = ppCat [ppr sty n, ppEquals, ppr sty prags] - - ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info) - = ppAbove (ppCat [ppPStr SLIT("{-spec'd-}"), ppr sty dfun_pragmas]) - (ppAboves (map pp_info spec_pragma_info)) - where - pp_info (ty_maybes, num_dicts, prags) - = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack, - ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags] - pp_ty Nothing = ppPStr SLIT("_N_") - pp_ty (Just t)= ppr sty t + ppr NoInstancePragmas = empty instance Outputable name => Outputable (GenPragmas name) where - ppr sty NoGenPragmas = ppNil - ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs) - = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def? - pp_str strictness, pp_unf unfolding, - pp_specs specs] - where - pp_arity Nothing = ppNil - pp_arity (Just i) = ppBeside (ppPStr SLIT("ARITY=")) (ppInt i) - - pp_upd Nothing = ppNil - pp_upd (Just u) = ppUpdateInfo sty u - - pp_str NoImpStrictness = ppNil - pp_str (ImpStrictness is_bot demands wrkr_prags) - = ppBesides [ppPStr SLIT("IS_BOT="), ppr sty is_bot, - ppPStr SLIT("STRICTNESS="), ppStr (showList demands ""), - ppPStr SLIT(" {"), ppr sty wrkr_prags, ppChar '}'] - - pp_unf NoImpUnfolding = ppPStr SLIT("NO_UNFOLDING") - pp_unf (ImpMagicUnfolding m) = ppBeside (ppPStr SLIT("MAGIC=")) (ppPStr m) - pp_unf (ImpUnfolding g core) = ppBeside (ppPStr SLIT("UNFOLD=")) (ppr sty core) - - pp_specs [] = ppNil - pp_specs specs - = ppBesides [ppPStr SLIT("SPECS=["), ppInterleave ppSP (map pp_spec specs), ppChar ']'] - where - pp_spec (ty_maybes, num_dicts, gprags) - = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags] - - pp_MaB Nothing = ppPStr SLIT("_N_") - pp_MaB (Just x) = ppr sty x -\end{code} - - -\begin{code} --} + ppr NoGenPragmas = empty \end{code}