never executed always true always false
1 {-# LANGUAGE LambdaCase #-}
2
3 {-
4 these are needed for the Outputable instance for GenTickish,
5 since we need XTickishId to be Outputable. This should immediately
6 resolve to something like Id.
7 -}
8 {-# LANGUAGE FlexibleContexts #-}
9 {-# LANGUAGE UndecidableInstances #-}
10
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12
13 {-
14 (c) The University of Glasgow 2006
15 (c) The AQUA Project, Glasgow University, 1996-1998
16
17
18 Printing of Core syntax
19 -}
20
21 module GHC.Core.Ppr (
22 pprCoreExpr, pprParendExpr,
23 pprCoreBinding, pprCoreBindings, pprCoreAlt,
24 pprCoreBindingWithSize, pprCoreBindingsWithSize,
25 pprRules, pprOptCo
26 ) where
27
28 import GHC.Prelude
29
30 import GHC.Core
31 import GHC.Core.Stats (exprStats)
32 import GHC.Types.Literal( pprLiteral )
33 import GHC.Types.Name( pprInfixName, pprPrefixName )
34 import GHC.Types.Var
35 import GHC.Types.Id
36 import GHC.Types.Id.Info
37 import GHC.Types.Demand
38 import GHC.Types.Cpr
39 import GHC.Core.DataCon
40 import GHC.Core.TyCon
41 import GHC.Core.TyCo.Ppr
42 import GHC.Core.Coercion
43 import GHC.Types.Basic
44 import GHC.Data.Maybe
45 import GHC.Utils.Misc
46 import GHC.Utils.Outputable
47 import GHC.Types.SrcLoc ( pprUserRealSpan )
48 import GHC.Types.Tickish
49
50 {-
51 ************************************************************************
52 * *
53 \subsection{Public interfaces for Core printing (excluding instances)}
54 * *
55 ************************************************************************
56
57 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
58 -}
59
60 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
61 pprCoreBinding :: OutputableBndr b => Bind b -> SDoc
62 pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
63 pprParendExpr :: OutputableBndr b => Expr b -> SDoc
64
65 pprCoreBindings = pprTopBinds noAnn
66 pprCoreBinding = pprTopBind noAnn
67
68 pprCoreBindingsWithSize :: [CoreBind] -> SDoc
69 pprCoreBindingWithSize :: CoreBind -> SDoc
70
71 pprCoreBindingsWithSize = pprTopBinds sizeAnn
72 pprCoreBindingWithSize = pprTopBind sizeAnn
73
74 instance OutputableBndr b => Outputable (Bind b) where
75 ppr bind = ppr_bind noAnn bind
76
77 instance OutputableBndr b => Outputable (Expr b) where
78 ppr expr = pprCoreExpr expr
79
80 instance OutputableBndr b => Outputable (Alt b) where
81 ppr expr = pprCoreAlt expr
82
83 {-
84 ************************************************************************
85 * *
86 \subsection{The guts}
87 * *
88 ************************************************************************
89 -}
90
91 -- | A function to produce an annotation for a given right-hand-side
92 type Annotation b = Expr b -> SDoc
93
94 -- | Annotate with the size of the right-hand-side
95 sizeAnn :: CoreExpr -> SDoc
96 sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)
97
98 -- | No annotation
99 noAnn :: Expr b -> SDoc
100 noAnn _ = empty
101
102 pprTopBinds :: OutputableBndr a
103 => Annotation a -- ^ generate an annotation to place before the
104 -- binding
105 -> [Bind a] -- ^ bindings to show
106 -> SDoc -- ^ the pretty result
107 pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)
108
109 pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc
110 pprTopBind ann (NonRec binder expr)
111 = ppr_binding ann (binder,expr) $$ blankLine
112
113 pprTopBind _ (Rec [])
114 = text "Rec { }"
115 pprTopBind ann (Rec (b:bs))
116 = vcat [text "Rec {",
117 ppr_binding ann b,
118 vcat [blankLine $$ ppr_binding ann b | b <- bs],
119 text "end Rec }",
120 blankLine]
121
122 ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc
123
124 ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)
125 ppr_bind ann (Rec binds) = vcat (map pp binds)
126 where
127 pp bind = ppr_binding ann bind <> semi
128
129 ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
130 ppr_binding ann (val_bdr, expr)
131 = vcat [ ann expr
132 , ppUnlessOption sdocSuppressTypeSignatures
133 (pprBndr LetBind val_bdr)
134 , pp_bind
135 ]
136 where
137 pp_val_bdr = pprPrefixOcc val_bdr
138
139 pp_bind = case bndrIsJoin_maybe val_bdr of
140 Nothing -> pp_normal_bind
141 Just ar -> pp_join_bind ar
142
143 pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
144
145 -- For a join point of join arity n, we want to print j = \x1 ... xn -> e
146 -- as "j x1 ... xn = e" to differentiate when a join point returns a
147 -- lambda (the first rendering looks like a nullary join point returning
148 -- an n-argument function).
149 pp_join_bind join_arity
150 | bndrs `lengthAtLeast` join_arity
151 = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
152 2 (equals <+> pprCoreExpr rhs)
153 | otherwise -- Yikes! A join-binding with too few lambda
154 -- Lint will complain, but we don't want to crash
155 -- the pretty-printer else we can't see what's wrong
156 -- So refer to printing j = e
157 = pp_normal_bind
158 where
159 (bndrs, body) = collectBinders expr
160 lhs_bndrs = take join_arity bndrs
161 rhs = mkLams (drop join_arity bndrs) body
162
163 pprParendExpr expr = ppr_expr parens expr
164 pprCoreExpr expr = ppr_expr noParens expr
165
166 noParens :: SDoc -> SDoc
167 noParens pp = pp
168
169 pprOptCo :: Coercion -> SDoc
170 -- Print a coercion optionally; i.e. honouring -dsuppress-coercions
171 pprOptCo co = sdocOption sdocSuppressCoercions $ \case
172 True -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> ppr (coercionType co)
173 False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]
174
175 ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
176 ppr_id_occ add_par id
177 | isJoinId id = add_par ((text "jump") <+> pp_id)
178 | otherwise = pp_id
179 where
180 pp_id = ppr id -- We could use pprPrefixOcc to print (+) etc, but this is
181 -- Core where we don't print things infix anyway, so doing
182 -- so just adds extra redundant parens
183
184 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
185 -- The function adds parens in context that need
186 -- an atomic value (e.g. function args)
187
188 ppr_expr add_par (Var id) = ppr_id_occ add_par id
189 ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird
190 ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
191 ppr_expr add_par (Lit lit) = pprLiteral add_par lit
192
193 ppr_expr add_par (Cast expr co)
194 = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co]
195
196 ppr_expr add_par expr@(Lam _ _)
197 = let
198 (bndrs, body) = collectBinders expr
199 in
200 add_par $
201 hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
202 2 (pprCoreExpr body)
203
204 ppr_expr add_par expr@(App {})
205 = sdocOption sdocSuppressTypeApplications $ \supp_ty_app ->
206 case collectArgs expr of { (fun, args) ->
207 let
208 pp_args = sep (map pprArg args)
209 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
210 pp_tup_args = pprWithCommas pprCoreExpr val_args
211 args'
212 | supp_ty_app = val_args
213 | otherwise = args
214 parens
215 | null args' = id
216 | otherwise = add_par
217 in
218 case fun of
219 Var f -> case isDataConWorkId_maybe f of
220 -- Notice that we print the *worker*
221 -- for tuples in paren'd format.
222 Just dc | saturated
223 , Just sort <- tyConTuple_maybe tc
224 -> tupleParens sort pp_tup_args
225 where
226 tc = dataConTyCon dc
227 saturated = val_args `lengthIs` idArity f
228
229 _ -> parens (hang fun_doc 2 pp_args)
230 where
231 fun_doc = ppr_id_occ noParens f
232
233 _ -> parens (hang (pprParendExpr fun) 2 pp_args)
234 }
235
236 ppr_expr add_par (Case expr var ty [Alt con args rhs])
237 = sdocOption sdocPrintCaseAsLet $ \case
238 True -> add_par $ -- See Note [Print case as let]
239 sep [ sep [ text "let! {"
240 <+> ppr_case_pat con args
241 <+> text "~"
242 <+> ppr_bndr var
243 , text "<-" <+> ppr_expr id expr
244 <+> text "} in" ]
245 , pprCoreExpr rhs
246 ]
247 False -> add_par $
248 sep [sep [sep [ text "case" <+> pprCoreExpr expr
249 , whenPprDebug (text "return" <+> ppr ty)
250 , text "of" <+> ppr_bndr var
251 ]
252 , char '{' <+> ppr_case_pat con args <+> arrow
253 ]
254 , pprCoreExpr rhs
255 , char '}'
256 ]
257 where
258 ppr_bndr = pprBndr CaseBind
259
260 ppr_expr add_par (Case expr var ty alts)
261 = add_par $
262 sep [sep [text "case"
263 <+> pprCoreExpr expr
264 <+> whenPprDebug (text "return" <+> ppr ty),
265 text "of" <+> ppr_bndr var <+> char '{'],
266 nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),
267 char '}'
268 ]
269 where
270 ppr_bndr = pprBndr CaseBind
271
272
273 -- special cases: let ... in let ...
274 -- ("disgusting" SLPJ)
275
276 {-
277 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
278 = add_par $
279 vcat [
280 hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
281 nest 2 (pprCoreExpr rhs),
282 text "} in",
283 pprCoreExpr body ]
284
285 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
286 = add_par
287 (hang (text "let {")
288 2 (hsep [ppr_binding (val_bdr,rhs),
289 text "} in"])
290 $$
291 pprCoreExpr expr)
292 -}
293
294
295 -- General case (recursive case, too)
296 ppr_expr add_par (Let bind expr)
297 = add_par $
298 sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),
299 pprCoreExpr expr]
300 where
301 keyword (NonRec b _)
302 | isJust (bndrIsJoin_maybe b) = text "join"
303 | otherwise = text "let"
304 keyword (Rec pairs)
305 | ((b,_):_) <- pairs
306 , isJust (bndrIsJoin_maybe b) = text "joinrec"
307 | otherwise = text "letrec"
308
309 ppr_expr add_par (Tick tickish expr)
310 = sdocOption sdocSuppressTicks $ \case
311 True -> ppr_expr add_par expr
312 False -> add_par (sep [ppr tickish, pprCoreExpr expr])
313
314 pprCoreAlt :: OutputableBndr a => Alt a -> SDoc
315 pprCoreAlt (Alt con args rhs)
316 = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
317
318 ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
319 ppr_case_pat (DataAlt dc) args
320 | Just sort <- tyConTuple_maybe tc
321 = tupleParens sort (pprWithCommas ppr_bndr args)
322 where
323 ppr_bndr = pprBndr CasePatBind
324 tc = dataConTyCon dc
325
326 ppr_case_pat con args
327 = ppr con <+> (fsep (map ppr_bndr args))
328 where
329 ppr_bndr = pprBndr CasePatBind
330
331
332 -- | Pretty print the argument in a function application.
333 pprArg :: OutputableBndr a => Expr a -> SDoc
334 pprArg (Type ty)
335 = ppUnlessOption sdocSuppressTypeApplications
336 (text "@" <> pprParendType ty)
337 pprArg (Coercion co) = text "@~" <> pprOptCo co
338 pprArg expr = pprParendExpr expr
339
340 {-
341 Note [Print case as let]
342 ~~~~~~~~~~~~~~~~~~~~~~~~
343 Single-branch case expressions are very common:
344 case x of y { I# x' ->
345 case p of q { I# p' -> ... } }
346 These are, in effect, just strict let's, with pattern matching.
347 With -dppr-case-as-let we print them as such:
348 let! { I# x' ~ y <- x } in
349 let! { I# p' ~ q <- p } in ...
350
351
352 Other printing bits-and-bobs used with the general @pprCoreBinding@
353 and @pprCoreExpr@ functions.
354
355
356 Note [Binding-site specific printing]
357 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
358
359 pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust
360 the information printed.
361
362 Let-bound binders are printed with their full type and idInfo.
363
364 Case-bound variables (both the case binder and pattern variables) are printed
365 without a type and without their unfolding.
366
367 Furthermore, a dead case-binder is completely ignored, while otherwise, dead
368 binders are printed as "_".
369 -}
370
371 -- These instances are sadly orphans
372
373 instance OutputableBndr Var where
374 pprBndr = pprCoreBinder
375 pprInfixOcc = pprInfixName . varName
376 pprPrefixOcc = pprPrefixName . varName
377 bndrIsJoin_maybe = isJoinId_maybe
378
379 instance Outputable b => OutputableBndr (TaggedBndr b) where
380 pprBndr _ b = ppr b -- Simple
381 pprInfixOcc b = ppr b
382 pprPrefixOcc b = ppr b
383 bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
384
385 pprCoreBinder :: BindingSite -> Var -> SDoc
386 pprCoreBinder LetBind binder
387 | isTyVar binder = pprKindedTyVarBndr binder
388 | otherwise = pprTypedLetBinder binder $$
389 ppIdInfo binder (idInfo binder)
390
391 -- Lambda bound type variables are preceded by "@"
392 pprCoreBinder bind_site bndr
393 = getPprDebug $ \debug ->
394 pprTypedLamBinder bind_site debug bndr
395
396 pprUntypedBinder :: Var -> SDoc
397 pprUntypedBinder binder
398 | isTyVar binder = text "@" <> ppr binder -- NB: don't print kind
399 | otherwise = pprIdBndr binder
400
401 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
402 -- For lambda and case binders, show the unfolding info (usually none)
403 pprTypedLamBinder bind_site debug_on var
404 = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
405 case () of
406 _
407 | not debug_on -- Show case-bound wild binders only if debug is on
408 , CaseBind <- bind_site
409 , isDeadBinder var -> empty
410
411 | not debug_on -- Even dead binders can be one-shot
412 , isDeadBinder var -> char '_' <+> ppWhen (isId var)
413 (pprIdBndrInfo (idInfo var))
414
415 | not debug_on -- No parens, no kind info
416 , CaseBind <- bind_site -> pprUntypedBinder var
417
418 | not debug_on
419 , CasePatBind <- bind_site -> pprUntypedBinder var
420
421 | suppress_sigs -> pprUntypedBinder var
422
423 | isTyVar var -> parens (pprKindedTyVarBndr var)
424
425 | otherwise -> parens (hang (pprIdBndr var)
426 2 (vcat [ dcolon <+> pprType (idType var)
427 , pp_unf]))
428 where
429 unf_info = realUnfoldingInfo (idInfo var)
430 pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info
431 | otherwise = empty
432
433 pprTypedLetBinder :: Var -> SDoc
434 -- Print binder with a type or kind signature (not paren'd)
435 pprTypedLetBinder binder
436 = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
437 case () of
438 _
439 | isTyVar binder -> pprKindedTyVarBndr binder
440 | suppress_sigs -> pprIdBndr binder
441 | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
442
443 pprKindedTyVarBndr :: TyVar -> SDoc
444 -- Print a type variable binder with its kind (but not if *)
445 pprKindedTyVarBndr tyvar
446 = text "@" <> pprTyVar tyvar
447
448 -- pprIdBndr does *not* print the type
449 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
450 pprIdBndr :: Id -> SDoc
451 pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)
452
453 pprIdBndrInfo :: IdInfo -> SDoc
454 pprIdBndrInfo info
455 = ppUnlessOption sdocSuppressIdInfo
456 (info `seq` doc) -- The seq is useful for poking on black holes
457 where
458 prag_info = inlinePragInfo info
459 occ_info = occInfo info
460 dmd_info = demandInfo info
461 lbv_info = oneShotInfo info
462
463 has_prag = not (isDefaultInlinePragma prag_info)
464 has_occ = not (isNoOccInfo occ_info)
465 has_dmd = not $ isTopDmd dmd_info
466 has_lbv = not (hasNoOneShotInfo lbv_info)
467
468 doc = showAttributes
469 [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
470 , (has_occ, text "Occ=" <> ppr occ_info)
471 , (has_dmd, text "Dmd=" <> ppr dmd_info)
472 , (has_lbv , text "OS=" <> ppr lbv_info)
473 ]
474
475 instance Outputable IdInfo where
476 ppr info = showAttributes
477 [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
478 , (has_occ, text "Occ=" <> ppr occ_info)
479 , (has_dmd, text "Dmd=" <> ppr dmd_info)
480 , (has_lbv , text "OS=" <> ppr lbv_info)
481 , (has_arity, text "Arity=" <> int arity)
482 , (has_called_arity, text "CallArity=" <> int called_arity)
483 , (has_caf_info, text "Caf=" <> ppr caf_info)
484 , (has_str_info, text "Str=" <> pprStrictness str_info)
485 , (has_unf, text "Unf=" <> ppr unf_info)
486 , (has_rules, text "RULES:" <+> vcat (map pprRule rules))
487 ]
488 where
489 prag_info = inlinePragInfo info
490 has_prag = not (isDefaultInlinePragma prag_info)
491
492 occ_info = occInfo info
493 has_occ = not (isManyOccs occ_info)
494
495 dmd_info = demandInfo info
496 has_dmd = not $ isTopDmd dmd_info
497
498 lbv_info = oneShotInfo info
499 has_lbv = not (hasNoOneShotInfo lbv_info)
500
501 arity = arityInfo info
502 has_arity = arity /= 0
503
504 called_arity = callArityInfo info
505 has_called_arity = called_arity /= 0
506
507 caf_info = cafInfo info
508 has_caf_info = not (mayHaveCafRefs caf_info)
509
510 str_info = dmdSigInfo info
511 has_str_info = not (isTopSig str_info)
512
513 unf_info = realUnfoldingInfo info
514 has_unf = hasSomeUnfolding unf_info
515
516 rules = ruleInfoRules (ruleInfo info)
517 has_rules = not (null rules)
518
519 {-
520 -----------------------------------------------------
521 -- IdDetails and IdInfo
522 -----------------------------------------------------
523 -}
524
525 ppIdInfo :: Id -> IdInfo -> SDoc
526 ppIdInfo id info
527 = ppUnlessOption sdocSuppressIdInfo $
528 showAttributes
529 [ (True, pp_scope <> ppr (idDetails id))
530 , (has_arity, text "Arity=" <> int arity)
531 , (has_called_arity, text "CallArity=" <> int called_arity)
532 , (has_caf_info, text "Caf=" <> ppr caf_info)
533 , (has_str_info, text "Str=" <> pprStrictness str_info)
534 , (has_cpr_info, text "Cpr=" <> ppr cpr_info)
535 , (has_unf, text "Unf=" <> ppr unf_info)
536 , (not (null rules), text "RULES:" <+> vcat (map pprRule rules))
537 ] -- Inline pragma, occ, demand, one-shot info
538 -- printed out with all binders (when debug is on);
539 -- see GHC.Core.Ppr.pprIdBndr
540 where
541 pp_scope | isGlobalId id = text "GblId"
542 | isExportedId id = text "LclIdX"
543 | otherwise = text "LclId"
544
545 arity = arityInfo info
546 has_arity = arity /= 0
547
548 called_arity = callArityInfo info
549 has_called_arity = called_arity /= 0
550
551 caf_info = cafInfo info
552 has_caf_info = not (mayHaveCafRefs caf_info)
553
554 str_info = dmdSigInfo info
555 has_str_info = not (isTopSig str_info)
556
557 cpr_info = cprSigInfo info
558 has_cpr_info = cpr_info /= topCprSig
559
560 unf_info = realUnfoldingInfo info
561 has_unf = hasSomeUnfolding unf_info
562
563 rules = ruleInfoRules (ruleInfo info)
564
565 showAttributes :: [(Bool,SDoc)] -> SDoc
566 showAttributes stuff
567 | null docs = empty
568 | otherwise = brackets (sep (punctuate comma docs))
569 where
570 docs = [d | (True,d) <- stuff]
571
572 {-
573 -----------------------------------------------------
574 -- Unfolding and UnfoldingGuidance
575 -----------------------------------------------------
576 -}
577
578 instance Outputable UnfoldingGuidance where
579 ppr UnfNever = text "NEVER"
580 ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
581 = text "ALWAYS_IF" <>
582 parens (text "arity=" <> int arity <> comma <>
583 text "unsat_ok=" <> ppr unsat_ok <> comma <>
584 text "boring_ok=" <> ppr boring_ok)
585 ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
586 = hsep [ text "IF_ARGS",
587 brackets (hsep (map int cs)),
588 int size,
589 int discount ]
590
591 instance Outputable UnfoldingSource where
592 ppr InlineCompulsory = text "Compulsory"
593 ppr InlineStable = text "InlineStable"
594 ppr InlineRhs = text "<vanilla>"
595
596 instance Outputable Unfolding where
597 ppr NoUnfolding = text "No unfolding"
598 ppr BootUnfolding = text "No unfolding (from boot)"
599 ppr (OtherCon cs) = text "OtherCon" <+> ppr cs
600 ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
601 = hang (text "DFun:" <+> char '\\'
602 <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
603 2 (ppr con <+> sep (map ppr args))
604 ppr (CoreUnfolding { uf_src = src
605 , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
606 , uf_is_conlike=conlike, uf_is_work_free=wf
607 , uf_expandable=exp, uf_guidance=g })
608 = text "Unf" <> braces (pp_info $$ pp_rhs)
609 where
610 pp_info = fsep $ punctuate comma
611 [ text "Src=" <> ppr src
612 , text "TopLvl=" <> ppr top
613 , text "Value=" <> ppr hnf
614 , text "ConLike=" <> ppr conlike
615 , text "WorkFree=" <> ppr wf
616 , text "Expandable=" <> ppr exp
617 , text "Guidance=" <> ppr g ]
618 pp_tmpl = ppUnlessOption sdocSuppressUnfoldings
619 (text "Tmpl=" <+> ppr rhs)
620 pp_rhs | isStableSource src = pp_tmpl
621 | otherwise = empty
622 -- Don't print the RHS or we get a quadratic
623 -- blowup in the size of the printout!
624
625 {-
626 -----------------------------------------------------
627 -- Rules
628 -----------------------------------------------------
629 -}
630
631 instance Outputable CoreRule where
632 ppr = pprRule
633
634 pprRules :: [CoreRule] -> SDoc
635 pprRules rules = vcat (map pprRule rules)
636
637 pprRule :: CoreRule -> SDoc
638 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
639 = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)
640
641 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
642 ru_bndrs = tpl_vars, ru_args = tpl_args,
643 ru_rhs = rhs })
644 = hang (doubleQuotes (ftext name) <+> ppr act)
645 4 (sep [text "forall" <+>
646 sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
647 nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
648 nest 2 (text "=" <+> pprCoreExpr rhs)
649 ])
650
651 {-
652 -----------------------------------------------------
653 -- Tickish
654 -----------------------------------------------------
655 -}
656
657 instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
658 ppr (HpcTick modl ix) =
659 hcat [text "hpc<",
660 ppr modl, comma,
661 ppr ix,
662 text ">"]
663 ppr (Breakpoint _ext ix vars) =
664 hcat [text "break<",
665 ppr ix,
666 text ">",
667 parens (hcat (punctuate comma (map ppr vars)))]
668 ppr (ProfNote { profNoteCC = cc,
669 profNoteCount = tick,
670 profNoteScope = scope }) =
671 case (tick,scope) of
672 (True,True) -> hcat [text "scctick<", ppr cc, char '>']
673 (True,False) -> hcat [text "tick<", ppr cc, char '>']
674 _ -> hcat [text "scc<", ppr cc, char '>']
675 ppr (SourceNote span _) =
676 hcat [ text "src<", pprUserRealSpan True span, char '>']