ghc/compiler/hsSyn/HsPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[HsPragmas]{Pragmas in Haskell interface files}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 See also: @Sig@ (``signatures'') which is where user-supplied pragmas
  11 for values show up; ditto @SpecInstSig@ (for instances) and
  12 @SpecDataSig@ (for data types).
  13
  14 \begin{code}
  15 #include "HsVersions.h"
  16
  17 module HsPragmas where
  18
  19 IMP_Ubiq()
  20
  21 -- friends:
  22 import HsTypes          ( HsType )
  23
  24 -- others:
  25 import IdInfo
  26 import SpecEnv          ( SpecEnv )
  27 import Outputable       ( Outputable(..) )
  28 import Pretty
  29 \end{code}
  30
  31 All the pragma stuff has changed.  Here are some placeholders!
  32
  33 \begin{code}
  34 data GenPragmas name  = NoGenPragmas
  35 data DataPragmas name = NoDataPragmas
  36 data InstancePragmas name = NoInstancePragmas
  37 data ClassOpPragmas name  = NoClassOpPragmas
  38 data ClassPragmas name  = NoClassPragmas
  39
  40 noClassPragmas = NoClassPragmas
  41 isNoClassPragmas NoClassPragmas = True
  42
  43 noDataPragmas = NoDataPragmas
  44 isNoDataPragmas NoDataPragmas = True
  45
  46 noGenPragmas = NoGenPragmas
  47 isNoGenPragmas NoGenPragmas = True
  48
  49 noInstancePragmas = NoInstancePragmas
  50 isNoInstancePragmas NoInstancePragmas = True
  51
  52 noClassOpPragmas = NoClassOpPragmas
  53 isNoClassOpPragmas NoClassOpPragmas = True
  54
  55 instance Outputable name => Outputable (ClassPragmas name) where
  56     ppr sty NoClassPragmas = empty
  57
  58 instance Outputable name => Outputable (ClassOpPragmas name) where
  59     ppr sty NoClassOpPragmas = empty
  60
  61 instance Outputable name => Outputable (InstancePragmas name) where
  62     ppr sty NoInstancePragmas = empty
  63
  64 instance Outputable name => Outputable (GenPragmas name) where
  65     ppr sty NoGenPragmas = empty
  66 \end{code}
  67
  68 ========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ==============
  69
  70 \begin{code}
  71 {-              COMMENTED OUT
  72
  73 Certain pragmas expect to be pinned onto certain constructs.
  74
  75 Pragma types may be parameterised, just as with any other
  76 abstract-syntax type.
  77
  78 For a @data@ declaration---indicates which specialisations exist.
  79 \begin{code}
  80 data DataPragmas name
  81   = NoDataPragmas
  82   | DataPragmas [[Maybe (HsType name)]]  -- types to which specialised
  83
  84 noDataPragmas = NoDataPragmas
  85 isNoDataPragmas NoDataPragmas = True
  86 \end{code}
  87
  88 These are {\em general} things you can know about any value:
  89 \begin{code}
  90 data GenPragmas name
  91   = NoGenPragmas
  92   | GenPragmas  (Maybe Int)             -- arity (maybe)
  93                 (Maybe UpdateInfo)      -- update info (maybe)
  94                 (ImpStrictness name)    -- strictness, worker-wrapper
  95                 (ImpUnfolding name)     -- unfolding (maybe)
  96                 [([Maybe (HsType name)], -- Specialisations: types to which spec'd;
  97                   Int,                     -- # dicts to ignore
  98                   GenPragmas name)]        -- Gen info about the spec'd version
  99
 100 noGenPragmas = NoGenPragmas
 101
 102 isNoGenPragmas NoGenPragmas = True
 103 isNoGenPragmas _            = False
 104
 105 data ImpUnfolding name
 106   = NoImpUnfolding
 107   | ImpMagicUnfolding FAST_STRING       -- magic "unfolding"
 108                                         -- known to the compiler by "String"
 109   | ImpUnfolding UnfoldingGuidance      -- always, if you like, etc.
 110                  (UnfoldingCoreExpr name)
 111
 112 data ImpStrictness name
 113   = NoImpStrictness
 114   | ImpStrictness Bool                  -- True <=> bottoming Id
 115                   [Demand]              -- demand info
 116                   (GenPragmas name)     -- about the *worker*
 117 \end{code}
 118
 119 For an ordinary imported function: it can have general pragmas (only).
 120
 121 For a class's super-class dictionary selectors:
 122 \begin{code}
 123 data ClassPragmas name
 124   = NoClassPragmas
 125   | SuperDictPragmas [GenPragmas name]  -- list mustn't be empty
 126
 127 noClassPragmas = NoClassPragmas
 128
 129 isNoClassPragmas NoClassPragmas = True
 130 isNoClassPragmas _              = False
 131 \end{code}
 132
 133 For a class's method selectors:
 134 \begin{code}
 135 data ClassOpPragmas name
 136   = NoClassOpPragmas
 137   | ClassOpPragmas  (GenPragmas name) -- for method selector
 138                     (GenPragmas name) -- for default method
 139
 140
 141 noClassOpPragmas = NoClassOpPragmas
 142
 143 isNoClassOpPragmas NoClassOpPragmas = True
 144 isNoClassOpPragmas _                = False
 145 \end{code}
 146
 147 \begin{code}
 148 data InstancePragmas name
 149   = NoInstancePragmas
 150
 151   | SimpleInstancePragma           -- nothing but for the dfun itself...
 152         (GenPragmas name)
 153
 154   | ConstantInstancePragma
 155         (GenPragmas name)          -- for the "dfun" itself
 156         [(name, GenPragmas name)]  -- one per class op
 157
 158   | SpecialisedInstancePragma
 159         (GenPragmas name)          -- for its "dfun"
 160         [([Maybe (HsType name)], -- specialised instance; type...
 161           Int,                     -- #dicts to ignore
 162           InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
 163
 164 noInstancePragmas = NoInstancePragmas
 165
 166 isNoInstancePragmas NoInstancePragmas = True
 167 isNoInstancePragmas _                 = False
 168 \end{code}
 169
 170 Some instances for printing (just for debugging, really)
 171 \begin{code}
 172 instance Outputable name => Outputable (ClassPragmas name) where
 173     ppr sty NoClassPragmas = empty
 174     ppr sty (SuperDictPragmas sdsel_prags)
 175       = ($$) (ptext SLIT("{-superdict pragmas-}"))
 176                 (ppr sty sdsel_prags)
 177
 178 instance Outputable name => Outputable (ClassOpPragmas name) where
 179     ppr sty NoClassOpPragmas = empty
 180     ppr sty (ClassOpPragmas op_prags defm_prags)
 181       = ($$) (hsep [ptext SLIT("{-meth-}"), ppr sty op_prags])
 182                 (hsep [ptext SLIT("{-defm-}"), ppr sty defm_prags])
 183
 184 instance Outputable name => Outputable (InstancePragmas name) where
 185     ppr sty NoInstancePragmas = empty
 186     ppr sty (SimpleInstancePragma dfun_pragmas)
 187       = hsep [ptext SLIT("{-dfun-}"), ppr sty dfun_pragmas]
 188     ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
 189       = ($$) (hsep [ptext SLIT("{-constm-}"), ppr sty dfun_pragmas])
 190                 (vcat (map pp_pair name_pragma_pairs))
 191       where
 192         pp_pair (n, prags)
 193           = hsep [ppr sty n, equals, ppr sty prags]
 194
 195     ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
 196       = ($$) (hsep [ptext SLIT("{-spec'd-}"), ppr sty dfun_pragmas])
 197                 (vcat (map pp_info spec_pragma_info))
 198       where
 199         pp_info (ty_maybes, num_dicts, prags)
 200           = hcat [brackets (hsep (map pp_ty ty_maybes)),
 201                        parens (int num_dicts), equals, ppr sty prags]
 202         pp_ty Nothing = ptext SLIT("_N_")
 203         pp_ty (Just t)= ppr sty t
 204
 205 instance Outputable name => Outputable (GenPragmas name) where
 206     ppr sty NoGenPragmas = empty
 207     ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
 208       = hsep [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
 209                pp_str strictness, pp_unf unfolding,
 210                pp_specs specs]
 211       where
 212         pp_arity Nothing  = empty
 213         pp_arity (Just i) = (<>) (ptext SLIT("ARITY=")) (int i)
 214
 215         pp_upd Nothing  = empty
 216         pp_upd (Just u) = ppUpdateInfo sty u
 217
 218         pp_str NoImpStrictness = empty
 219         pp_str (ImpStrictness is_bot demands wrkr_prags)
 220           = hcat [ptext SLIT("IS_BOT="), ppr sty is_bot,
 221                        ptext SLIT("STRICTNESS="), text (showList demands ""),
 222                        ptext SLIT(" {"), ppr sty wrkr_prags, char '}']
 223
 224         pp_unf NoImpUnfolding = ptext SLIT("NO_UNFOLDING")
 225         pp_unf (ImpMagicUnfolding m) = (<>) (ptext SLIT("MAGIC=")) (ptext m)
 226         pp_unf (ImpUnfolding g core) = (<>) (ptext SLIT("UNFOLD=")) (ppr sty core)
 227
 228         pp_specs [] = empty
 229         pp_specs specs
 230           = hcat [ptext SLIT("SPECS=["), hsep (map pp_spec specs), char ']']
 231           where
 232             pp_spec (ty_maybes, num_dicts, gprags)
 233               = hsep [brackets (hsep (map pp_MaB ty_maybes)), int num_dicts, ppr sty gprags]
 234
 235             pp_MaB Nothing  = ptext SLIT("_N_")
 236             pp_MaB (Just x) = ppr sty x
 237 \end{code}
 238
 239
 240 \begin{code}
 241 -}
 242 \end{code}