2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprParendExpr,
13 pprCoreBinding, pprCoreBindings, pprIdBndr,
14 pprCoreBinding, pprCoreBindings, pprCoreAlt,
15 pprIdRules, pprCoreRule
18 #include "HsVersions.h"
21 import CostCentre ( pprCostCentreCore )
22 import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
23 idInfo, idInlinePragma, idOccInfo,
27 globalIdDetails, isGlobalId, isExportedId,
28 isSpecPragmaId, idNewDemandInfo
30 import Var ( isTyVar )
31 import IdInfo ( IdInfo, megaSeqIdInfo,
32 arityInfo, ppArityInfo,
33 specInfo, ppStrictnessInfo,
34 workerInfo, ppWorkerInfo,
35 tyGenInfo, ppTyGenInfo,
42 import DataCon ( dataConTyCon )
43 import TyCon ( tupleTyConBoxity, isTupleTyCon )
44 import PprType ( pprParendType, pprTyVarBndr )
45 import BasicTypes ( tupleParens )
47 import Util ( lengthIs )
51 %************************************************************************
53 \subsection{Public interfaces for Core printing (excluding instances)}
55 %************************************************************************
57 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
58 function for ``major'' val_bdrs (those next to equal signs :-),
59 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
60 usually be called through some intermediary.
62 The binder/occ printers take the default ``homogenized'' (see
63 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
64 homogenized one, or they can ignore it completely. In other words,
65 the things passed in act as ``hooks'', getting the last word on how to
68 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
70 Un-annotated core dumps
71 ~~~~~~~~~~~~~~~~~~~~~~~
73 pprCoreBindings :: [CoreBind] -> SDoc
74 pprCoreBinding :: CoreBind -> SDoc
75 pprCoreExpr :: CoreExpr -> SDoc
76 pprParendExpr :: CoreExpr -> SDoc
78 pprCoreBindings = pprTopBinds pprCoreEnv
79 pprCoreBinding = pprTopBind pprCoreEnv
80 pprCoreExpr = ppr_noparend_expr pprCoreEnv
81 pprParendExpr = ppr_parend_expr pprCoreEnv
82 pprArg = ppr_arg pprCoreEnv
83 pprCoreAlt = ppr_alt pprCoreEnv
85 pprCoreEnv = initCoreEnv pprCoreBinder
88 Printer for unfoldings in interfaces
89 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
91 instance Outputable b => Outputable (Bind b) where
92 ppr bind = ppr_bind pprGenericEnv bind
94 instance Outputable b => Outputable (Expr b) where
95 ppr expr = ppr_noparend_expr pprGenericEnv expr
97 pprGenericEnv :: Outputable b => PprEnv b
98 pprGenericEnv = initCoreEnv (\site -> ppr)
101 %************************************************************************
103 \subsection{Instance declarations for Core printing}
105 %************************************************************************
111 (Just pprCostCentreCore) -- Cost centres
113 (Just ppr) -- tyvar occs
114 (Just pprParendType) -- types
116 (Just pbdr) (Just ppr) -- value vars
117 -- Use pprIdBndr for this last one as a debugging device.
120 %************************************************************************
122 \subsection{The guts}
124 %************************************************************************
127 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
129 pprTopBind pe (NonRec binder expr)
130 = ppr_binding_pe pe (binder,expr) $$ text ""
132 pprTopBind pe (Rec binds)
133 = vcat [ptext SLIT("Rec {"),
134 vcat (map (ppr_binding_pe pe) binds),
135 ptext SLIT("end Rec }"),
140 ppr_bind :: PprEnv b -> Bind b -> SDoc
142 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
143 ppr_bind pe (Rec binds) = vcat (map pp binds)
145 pp bind = ppr_binding_pe pe bind <> semi
147 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
148 ppr_binding_pe pe (val_bdr, expr)
149 = sep [pBndr pe LetBind val_bdr,
150 nest 2 (equals <+> ppr_noparend_expr pe expr)]
154 ppr_parend_expr pe expr = ppr_expr parens pe expr
155 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
157 noParens :: SDoc -> SDoc
162 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
163 -- The function adds parens in context that need
164 -- an atomic value (e.g. function args)
166 ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
168 ppr_expr add_par pe (Var name) = pOcc pe name
169 ppr_expr add_par pe (Lit lit) = ppr lit
171 ppr_expr add_par pe expr@(Lam _ _)
173 (bndrs, body) = collectBinders expr
176 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
177 2 (ppr_noparend_expr pe body)
179 ppr_expr add_par pe expr@(App fun arg)
180 = case collectArgs expr of { (fun, args) ->
182 pp_args = sep (map (ppr_arg pe) args)
183 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
184 pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
187 Var f -> case isDataConId_maybe f of
188 -- Notice that we print the *worker*
189 -- for tuples in paren'd format.
190 Just dc | saturated && isTupleTyCon tc
191 -> tupleParens (tupleTyConBoxity tc) pp_tup_args
194 saturated = val_args `lengthIs` idArity f
196 other -> add_par (hang (pOcc pe f) 2 pp_args)
198 other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
201 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
203 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
204 hsep [ptext SLIT("of"),
207 ppr_case_pat pe con args
209 ppr_noparend_expr pe rhs,
213 ppr_bndr = pBndr pe CaseBind
215 ppr_expr add_par pe (Case expr var alts)
217 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
218 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
219 nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
223 ppr_bndr = pBndr pe CaseBind
226 -- special cases: let ... in let ...
227 -- ("disgusting" SLPJ)
229 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
232 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
233 nest 2 (ppr_noparend_expr pe rhs),
235 ppr_noparend_expr pe body ]
237 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
239 (hang (ptext SLIT("let {"))
240 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
241 2 (ppr_noparend_expr pe rhs),
244 ppr_noparend_expr pe expr)
246 -- general case (recursive case, too)
247 ppr_expr add_par pe (Let bind expr)
249 sep [hang (ptext keyword) 2 (ppr_bind pe bind),
250 hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
252 keyword = case bind of
253 Rec _ -> SLIT("__letrec {")
254 NonRec _ _ -> SLIT("let {")
256 ppr_expr add_par pe (Note (SCC cc) expr)
257 = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
260 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
262 getPprStyle $ \ sty ->
263 if debugStyle sty then
264 sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
265 ppr_parend_expr pe expr]
267 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
268 ppr_parend_expr pe expr]
270 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
272 sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
273 ppr_parend_expr pe expr]
276 ppr_expr add_par pe (Note InlineCall expr)
277 = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
279 ppr_expr add_par pe (Note InlineMe expr)
280 = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
282 ppr_alt pe (con, args, rhs)
283 = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
285 ppr_case_pat pe con@(DataAlt dc) args
287 = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
289 ppr_bndr = pBndr pe CaseBind
292 ppr_case_pat pe con args
293 = ppr con <+> hsep (map ppr_bndr args) <+> arrow
295 ppr_bndr = pBndr pe CaseBind
297 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
298 ppr_arg pe expr = ppr_parend_expr pe expr
300 arrow = ptext SLIT("->")
303 Other printing bits-and-bobs used with the general @pprCoreBinding@
304 and @pprCoreExpr@ functions.
307 -- Used for printing dump info
308 pprCoreBinder LetBind binder
309 = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
311 sig = pprTypedBinder binder
312 pragmas = ppIdInfo binder (idInfo binder)
314 -- Lambda bound type variables are preceded by "@"
315 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
317 -- Case bound things don't get a signature or a herald
318 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
320 pprUntypedBinder binder
321 | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
322 | otherwise = pprIdBndr binder
324 pprTypedBinder binder
325 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
326 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
327 -- The space before the :: is important; it helps the lexer
328 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
330 -- It's important that the type is parenthesised too, at least when
331 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
333 -- pprIdBndr does *not* print the type
334 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
335 pprIdBndr id = ppr id <+>
336 (megaSeqIdInfo (idInfo id) `seq`
337 -- Useful for poking on black holes
338 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
339 #ifdef OLD_STRICTNESS
340 ppr (idDemandInfo id) <+>
342 ppr (idNewDemandInfo id) <+>
343 ppr (idLBVarInfo id)))
348 pprIdDetails :: Id -> SDoc
349 pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
350 | isExportedId id = ptext SLIT("[Exported]")
351 | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
354 ppIdInfo :: Id -> IdInfo -> SDoc
356 = hsep [ ppArityInfo a,
358 ppWorkerInfo (workerInfo info),
359 #ifdef OLD_STRICTNESS
363 ppr (newStrictnessInfo info),
364 vcat (map (pprCoreRule (ppr b)) (rulesRules p))
365 -- Inline pragma, occ, demand, lbvar info
366 -- printed out with all binders (when debug is on);
367 -- see PprCore.pprIdBndr
372 #ifdef OLD_STRICTNESS
373 s = strictnessInfo info
381 pprIdRules :: [IdCoreRule] -> SDoc
382 pprIdRules rules = vcat (map pprIdRule rules)
384 pprIdRule :: IdCoreRule -> SDoc
385 pprIdRule (id,rule) = pprCoreRule (ppr id) rule
387 pprCoreRule :: SDoc -> CoreRule -> SDoc
388 pprCoreRule pp_fn (BuiltinRule name _)
389 = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon
390 <+> doubleQuotes (ftext name))
392 pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
393 = doubleQuotes (ftext name) <+> ppr act <+>
395 ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
396 nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
397 nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)