ghc/compiler/abstractSyn/HsPragmas.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   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 @SpecialisedInstanceSig@ (for instances) and
  12 @DataTypeSig@ (for data types and type synonyms).
  13
  14 \begin{code}
  15 #include "HsVersions.h"
  16
  17 module HsPragmas where
  18
  19 import HsCore           ( UnfoldingCoreExpr, UfCostCentre )
  20 import HsDecls          ( ConDecl )
  21 import HsTypes          ( MonoType, PolyType )
  22 import IdInfo
  23 import Maybes           ( Maybe(..) )
  24 import Name             ( Name )
  25 import Outputable       -- class for printing, forcing
  26 import Pretty           -- pretty-printing utilities
  27 import ProtoName        ( ProtoName(..) ) -- .. is for pragmas only
  28 import Util
  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---makes visible the constructors for an
  37 abstract @data@ type and indicates which specialisations exist.
  38 \begin{code}
  39 data DataPragmas name
  40   = DataPragmas [ConDecl name]             -- hidden data constructors
  41                 [[Maybe (MonoType name)]]  -- types to which speciaised
  42
  43 type ProtoNameDataPragmas = DataPragmas ProtoName
  44 type RenamedDataPragmas   = DataPragmas Name
  45 \end{code}
  46
  47 For a @type@ declaration---declare that it should be treated as
  48 ``abstract'' (flag any use of its expansion as an error):
  49 \begin{code}
  50 data TypePragmas
  51   = NoTypePragmas
  52   | AbstractTySynonym
  53 \end{code}
  54
  55 These are {\em general} things you can know about any value:
  56 \begin{code}
  57 data GenPragmas name
  58   = NoGenPragmas
  59   | GenPragmas  (Maybe Int)             -- arity (maybe)
  60                 (Maybe UpdateInfo)      -- update info (maybe)
  61                 DeforestInfo            -- deforest info
  62                 (ImpStrictness name)    -- strictness, worker-wrapper
  63                 (ImpUnfolding name)     -- unfolding (maybe)
  64                 [([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
  65                   Int,                     -- # dicts to ignore
  66                   GenPragmas name)]        -- Gen info about the spec'd version
  67
  68 type ProtoNameGenPragmas = GenPragmas ProtoName
  69 type RenamedGenPragmas   = GenPragmas Name
  70
  71 data ImpUnfolding name
  72   = NoImpUnfolding
  73   | ImpMagicUnfolding FAST_STRING       -- magic "unfolding"
  74                                         -- known to the compiler by "String"
  75   | ImpUnfolding UnfoldingGuidance      -- always, if you like, etc.
  76                  (UnfoldingCoreExpr name)
  77
  78 type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName
  79
  80 data ImpStrictness name
  81   = NoImpStrictness
  82   | ImpStrictness Bool                  -- True <=> bottoming Id
  83                   [Demand]              -- demand info
  84                   (GenPragmas name)     -- about the *worker*
  85
  86 type RenamedImpStrictness = ImpStrictness Name
  87 \end{code}
  88
  89 For an ordinary imported function: it can have general pragmas (only).
  90
  91 For a class's super-class dictionary selectors:
  92 \begin{code}
  93 data ClassPragmas name
  94   = NoClassPragmas
  95   | SuperDictPragmas [GenPragmas name]  -- list mustn't be empty
  96
  97 type ProtoNameClassPragmas = ClassPragmas ProtoName
  98 type RenamedClassPragmas   = ClassPragmas Name
  99 \end{code}
 100
 101 For a class's method selectors:
 102 \begin{code}
 103 data ClassOpPragmas name
 104   = NoClassOpPragmas
 105   | ClassOpPragmas  (GenPragmas name) -- for method selector
 106                     (GenPragmas name) -- for default method
 107
 108 type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
 109 type RenamedClassOpPragmas   = ClassOpPragmas Name
 110 \end{code}
 111
 112 \begin{code}
 113 data InstancePragmas name
 114   = NoInstancePragmas
 115
 116   | SimpleInstancePragma           -- nothing but for the dfun itself...
 117         (GenPragmas name)
 118
 119   | ConstantInstancePragma
 120         (GenPragmas name)          -- for the "dfun" itself
 121         [(name, GenPragmas name)]  -- one per class op
 122
 123   | SpecialisedInstancePragma
 124         (GenPragmas name)          -- for its "dfun"
 125         [([Maybe (MonoType name)], -- specialised instance; type...
 126           Int,                     -- #dicts to ignore
 127           InstancePragmas name)]   -- (no SpecialisedInstancePragma please!)
 128
 129 type ProtoNameInstancePragmas = InstancePragmas ProtoName
 130 type RenamedInstancePragmas   = InstancePragmas Name
 131 \end{code}
 132
 133 Some instances for printing (just for debugging, really)
 134 \begin{code}
 135 instance Outputable name => Outputable (ClassPragmas name) where
 136     ppr sty NoClassPragmas = ppNil
 137     ppr sty (SuperDictPragmas sdsel_prags)
 138       = ppAbove (ppStr "{-superdict pragmas-}")
 139                 (ppr sty sdsel_prags)
 140
 141 instance Outputable name => Outputable (ClassOpPragmas name) where
 142     ppr sty NoClassOpPragmas = ppNil
 143     ppr sty (ClassOpPragmas op_prags defm_prags)
 144       = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
 145                 (ppCat [ppStr "{-defm-}", ppr sty defm_prags])
 146
 147 instance Outputable name => Outputable (InstancePragmas name) where
 148     ppr sty NoInstancePragmas = ppNil
 149     ppr sty (SimpleInstancePragma dfun_pragmas)
 150       = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
 151     ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
 152       = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
 153                 (ppAboves (map pp_pair name_pragma_pairs))
 154       where
 155         pp_pair (n, prags)
 156           = ppCat [ppr sty n, ppEquals, ppr sty prags]
 157
 158     ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
 159       = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
 160                 (ppAboves (map pp_info spec_pragma_info))
 161       where
 162         pp_info (ty_maybes, num_dicts, prags)
 163           = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
 164                        ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
 165         pp_ty Nothing = ppStr "_N_"
 166         pp_ty (Just t)= ppr sty t
 167
 168 instance Outputable name => Outputable (GenPragmas name) where
 169     ppr sty NoGenPragmas = ppNil
 170     ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
 171       = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
 172                pp_str strictness, pp_unf unfolding,
 173                pp_specs specs]
 174       where
 175         pp_arity Nothing  = ppNil
 176         pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
 177
 178         pp_upd Nothing  = ppNil
 179         pp_upd (Just u) = ppInfo sty id u
 180
 181         pp_str NoImpStrictness = ppNil
 182         pp_str (ImpStrictness is_bot demands wrkr_prags)
 183           = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
 184                        ppStr "STRICTNESS=", ppStr (showList demands ""),
 185                        ppStr " {", ppr sty wrkr_prags, ppStr "}"]
 186
 187         pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
 188         pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
 189         pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
 190
 191         pp_specs [] = ppNil
 192         pp_specs specs
 193           = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
 194           where
 195             pp_spec (ty_maybes, num_dicts, gprags)
 196               = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
 197
 198             pp_MaB Nothing  = ppStr "_N_"
 199             pp_MaB (Just x) = ppr sty x
 200 \end{code}