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
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
|
%
% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
\section[PprCore]{Printing of Core syntax, including for interfaces}
%* *
%************************************************************************
\begin{code}
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprIdRules
) where
#include "HsVersions.h"
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Var ( Var )
import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
#ifdef OLD_STRICTNESS
idDemandInfo,
#endif
globalIdDetails, isGlobalId, isExportedId,
isSpecPragmaId, idNewDemandInfo
)
import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
newStrictnessInfo, cafInfo, ppCafInfo,
#ifdef OLD_STRICTNESS
cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo,
#endif
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
import Type ( pprParendType, pprType, pprParendKind )
import BasicTypes ( tupleParens )
import Util ( lengthIs )
import Outputable
import FastString ( mkFastString )
\end{code}
%************************************************************************
%* *
\subsection{Public interfaces for Core printing (excluding instances)}
%* *
%************************************************************************
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
\begin{code}
pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
pprCoreBinding :: OutputableBndr b => Bind b -> SDoc
pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
pprParendExpr :: OutputableBndr b => Expr b -> SDoc
pprCoreBindings = pprTopBinds
pprCoreBinding = pprTopBind
instance OutputableBndr b => Outputable (Bind b) where
ppr bind = ppr_bind bind
instance OutputableBndr b => Outputable (Expr b) where
ppr expr = pprCoreExpr expr
\end{code}
%************************************************************************
%* *
\subsection{The guts}
%* *
%************************************************************************
\begin{code}
pprTopBinds binds = vcat (map pprTopBind binds)
pprTopBind (NonRec binder expr)
= ppr_binding (binder,expr) $$ text ""
pprTopBind (Rec binds)
= vcat [ptext SLIT("Rec {"),
vcat (map ppr_binding binds),
ptext SLIT("end Rec }"),
text ""]
\end{code}
\begin{code}
ppr_bind :: OutputableBndr b => Bind b -> SDoc
ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
ppr_bind (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding bind <> semi
ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
ppr_binding (val_bdr, expr)
= pprBndr LetBind val_bdr $$
(ppr val_bdr <+> equals <+> pprCoreExpr expr)
\end{code}
\begin{code}
pprParendExpr expr = ppr_expr parens expr
pprCoreExpr expr = ppr_expr noParens expr
noParens :: SDoc -> SDoc
noParens pp = pp
\end{code}
\begin{code}
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
ppr_expr add_par (Var name) = ppr name
ppr_expr add_par (Lit lit) = ppr lit
ppr_expr add_par expr@(Lam _ _)
= let
(bndrs, body) = collectBinders expr
in
add_par $
hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (pprCoreExpr body)
ppr_expr add_par expr@(App fun arg)
= case collectArgs expr of { (fun, args) ->
let
pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
pp_tup_args = sep (punctuate comma (map pprArg val_args))
in
case fun of
Var f -> case isDataConWorkId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
Just dc | saturated && isTupleTyCon tc
-> tupleParens (tupleTyConBoxity tc) pp_tup_args
where
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
other -> add_par (hang (ppr f) 2 pp_args)
other -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
-- gaw 2004
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
= add_par $
sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
hsep [ptext SLIT("of"),
ppr_bndr var,
char '{',
ppr_case_pat con args
]],
pprCoreExpr rhs,
char '}'
]
where
ppr_bndr = pprBndr CaseBind
-- gaw 2004
ppr_expr add_par (Case expr var ty alts)
= add_par $
sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr,
ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
char '}'
]
where
ppr_bndr = pprBndr CaseBind
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
{-
ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
= add_par $
vcat [
hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
nest 2 (pprCoreExpr rhs),
ptext SLIT("} in"),
pprCoreExpr body ]
-}
ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= add_par
(hang (ptext SLIT("let {"))
2 (hsep [ppr_binding (val_bdr,rhs),
ptext SLIT("} in")])
$$
pprCoreExpr expr)
-- general case (recursive case, too)
ppr_expr add_par (Let bind expr)
= add_par $
sep [hang (ptext keyword) 2 (ppr_bind bind),
hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
where
keyword = case bind of
Rec _ -> SLIT("__letrec {")
NonRec _ _ -> SLIT("let {")
ppr_expr add_par (Note (SCC cc) expr)
= add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
#ifdef DEBUG
ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
= add_par $
getPprStyle $ \ sty ->
if debugStyle sty then
sep [ptext SLIT("__coerce") <+>
sep [pprParendType to_ty, pprParendType from_ty],
pprParendExpr expr]
else
sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty],
pprParendExpr expr]
#else
ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
= add_par $
sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)],
pprParendExpr expr]
#endif
ppr_expr add_par (Note InlineCall expr)
= add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr)
ppr_expr add_par (Note InlineMe expr)
= add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
ppr_expr add_par (Note (CoreNote s) expr)
= add_par $
sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
pprParendExpr expr]
pprCoreAlt (con, args, rhs)
= hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
ppr_case_pat con@(DataAlt dc) args
| isTupleTyCon tc
= tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
where
ppr_bndr = pprBndr CaseBind
tc = dataConTyCon dc
ppr_case_pat con args
= ppr con <+> hsep (map ppr_bndr args) <+> arrow
where
ppr_bndr = pprBndr CaseBind
pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
pprArg expr = pprParendExpr expr
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
\begin{code}
instance OutputableBndr Var where
pprBndr = pprCoreBinder
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
= vcat [sig, pprIdDetails binder, pragmas]
where
sig = pprTypedBinder binder
pragmas = ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
-- Case bound things don't get a signature or a herald
pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
pprUntypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedBinder binder
| isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
| otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
pprTyVarBndr :: TyVar -> SDoc
pprTyVarBndr tyvar
= getPprStyle $ \ sty ->
if debugStyle sty then
hsep [ppr tyvar, dcolon, pprParendKind kind]
-- See comments with ppDcolon in PprCore.lhs
else
ppr tyvar
where
kind = tyVarKind tyvar
-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr id = ppr id <+>
(megaSeqIdInfo (idInfo id) `seq`
-- Useful for poking on black holes
ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
#ifdef OLD_STRICTNESS
ppr (idDemandInfo id) <+>
#endif
ppr (idNewDemandInfo id) <+>
ppr (idLBVarInfo id)))
\end{code}
\begin{code}
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
| isExportedId id = ptext SLIT("[Exported]")
| isSpecPragmaId id = ptext SLIT("[SpecPrag]")
| otherwise = empty
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
= hsep [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppStrictnessInfo s,
ppCprInfo m,
#endif
pprNewStrictness (newStrictnessInfo info),
vcat (map (pprCoreRule (ppr b)) (rulesRules p))
-- Inline pragma, occ, demand, lbvar info
-- printed out with all binders (when debug is on);
-- see PprCore.pprIdBndr
]
where
a = arityInfo info
#ifdef OLD_STRICTNESS
s = strictnessInfo info
m = cprInfo info
#endif
p = specInfo info
\end{code}
\begin{code}
pprIdRules :: [IdCoreRule] -> SDoc
pprIdRules rules = vcat (map pprIdRule rules)
pprIdRule :: IdCoreRule -> SDoc
pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule name _)
= ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
= doubleQuotes (ftext name) <+> ppr act <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
] <+> semi
\end{code}
|