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