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