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 HsCore           ( UnfoldingCoreExpr )
  23 import HsTypes          ( MonoType )
  24
  25 -- others:
  26 import IdInfo
  27 import Outputable       ( Outputable(..) )
  28 import Pretty
  29 \end{code}
  30
  31 Certain pragmas expect to be pinned onto certain constructs.
  32
  33 Pragma types may be parameterised, just as with any other
  34 abstract-syntax type.
  35
  36 For a @data@ declaration---indicates which specialisations exist.
  37 \begin{code}
  38 data DataPragmas name
  39   = NoDataPragmas
  40   | DataPragmas [[Maybe (MonoType name)]]  -- types to which specialised
  41
  42 noDataPragmas = NoDataPragmas
  43
  44 isNoDataPragmas NoDataPragmas = True
  45 isNoDataPragmas _             = False
  46 \end{code}
  47
  48 These are {\em general} things you can know about any value:
  49 \begin{code}
  50 data GenPragmas name
  51   = NoGenPragmas
  52   | GenPragmas  (Maybe Int)             -- arity (maybe)
  53                 (Maybe UpdateInfo)      -- update info (maybe)
  54                 DeforestInfo            -- deforest info
  55                 (ImpStrictness name)    -- strictness, worker-wrapper
  56                 (ImpUnfolding name)     -- unfolding (maybe)
  57                 [([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
  58                   Int,                     -- # dicts to ignore
  59                   GenPragmas name)]        -- Gen info about the spec'd version
  60
  61 noGenPragmas = NoGenPragmas
  62
  63 isNoGenPragmas NoGenPragmas = True
  64 isNoGenPragmas _            = False
  65
  66 data ImpUnfolding name
  67   = NoImpUnfolding
  68   | ImpMagicUnfolding FAST_STRING       -- magic "unfolding"
  69                                         -- known to the compiler by "String"
  70   | ImpUnfolding UnfoldingGuidance      -- always, if you like, etc.
  71                  (UnfoldingCoreExpr name)
  72
  73 data ImpStrictness name
  74   = NoImpStrictness
  75   | ImpStrictness Bool                  -- True <=> bottoming Id
  76                   [Demand]              -- demand info
  77                   (GenPragmas name)     -- about the *worker*
  78 \end{code}
  79
  80 For an ordinary imported function: it can have general pragmas (only).
  81
  82 For a class's super-class dictionary selectors:
  83 \begin{code}
  84 data ClassPragmas name
  85   = NoClassPragmas
  86   | SuperDictPragmas [GenPragmas name]  -- list mustn't be empty
  87
  88 noClassPragmas = NoClassPragmas
  89
  90 isNoClassPragmas NoClassPragmas = True
  91 isNoClassPragmas _              = False
  92 \end{code}
  93
  94 For a class's method selectors:
  95 \begin{code}
  96 data ClassOpPragmas name
  97   = NoClassOpPragmas
  98   | ClassOpPragmas  (GenPragmas name) -- for method selector
  99                     (GenPragmas name) -- for default method
 100
 101
 102 noClassOpPragmas = NoClassOpPragmas
 103
 104 isNoClassOpPragmas NoClassOpPragmas = True
 105 isNoClassOpPragmas _                = False
 106 \end{code}
 107
 108 \begin{code}
 109 data InstancePragmas name
 110   = NoInstancePragmas
 111
 112   | SimpleInstancePragma           -- nothing but for the dfun itself...
 113         (GenPragmas name)
 114
 115   | ConstantInstancePragma
 116         (GenPragmas name)          -- for the "dfun" itself
 117         [(name, GenPragmas name)]  -- one per class op
 118
 119   | SpecialisedInstancePragma
 120         (GenPragmas name)          -- for its "dfun"
 121         [([Maybe (MonoType name)], -- specialised instance; type...
 122           Int,                     -- #dicts to ignore
 123           InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
 124
 125 noInstancePragmas = NoInstancePragmas
 126
 127 isNoInstancePragmas NoInstancePragmas = True
 128 isNoInstancePragmas _                 = False
 129 \end{code}
 130
 131 Some instances for printing (just for debugging, really)
 132 \begin{code}
 133 instance Outputable name => Outputable (ClassPragmas name) where
 134     ppr sty NoClassPragmas = ppNil
 135     ppr sty (SuperDictPragmas sdsel_prags)
 136       = ppAbove (ppStr "{-superdict pragmas-}")
 137                 (ppr sty sdsel_prags)
 138
 139 instance Outputable name => Outputable (ClassOpPragmas name) where
 140     ppr sty NoClassOpPragmas = ppNil
 141     ppr sty (ClassOpPragmas op_prags defm_prags)
 142       = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
 143                 (ppCat [ppStr "{-defm-}", ppr sty defm_prags])
 144
 145 instance Outputable name => Outputable (InstancePragmas name) where
 146     ppr sty NoInstancePragmas = ppNil
 147     ppr sty (SimpleInstancePragma dfun_pragmas)
 148       = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
 149     ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
 150       = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
 151                 (ppAboves (map pp_pair name_pragma_pairs))
 152       where
 153         pp_pair (n, prags)
 154           = ppCat [ppr sty n, ppEquals, ppr sty prags]
 155
 156     ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
 157       = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
 158                 (ppAboves (map pp_info spec_pragma_info))
 159       where
 160         pp_info (ty_maybes, num_dicts, prags)
 161           = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
 162                        ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
 163         pp_ty Nothing = ppStr "_N_"
 164         pp_ty (Just t)= ppr sty t
 165
 166 instance Outputable name => Outputable (GenPragmas name) where
 167     ppr sty NoGenPragmas = ppNil
 168     ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
 169       = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
 170                pp_str strictness, pp_unf unfolding,
 171                pp_specs specs]
 172       where
 173         pp_arity Nothing  = ppNil
 174         pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
 175
 176         pp_upd Nothing  = ppNil
 177         pp_upd (Just u) = ppInfo sty id u
 178
 179         pp_str NoImpStrictness = ppNil
 180         pp_str (ImpStrictness is_bot demands wrkr_prags)
 181           = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
 182                        ppStr "STRICTNESS=", ppStr (showList demands ""),
 183                        ppStr " {", ppr sty wrkr_prags, ppStr "}"]
 184
 185         pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
 186         pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
 187         pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
 188
 189         pp_specs [] = ppNil
 190         pp_specs specs
 191           = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
 192           where
 193             pp_spec (ty_maybes, num_dicts, gprags)
 194               = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
 195
 196             pp_MaB Nothing  = ppStr "_N_"
 197             pp_MaB (Just x) = ppr sty x
 198 \end{code}