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