ghc-9.14.1: GHC/Core/Ppr.hs
{-# LANGUAGE LambdaCase #-}
{-
these are needed for the Outputable instance for GenTickish,
since we need XTickishId to be Outputable. This should immediately
resolve to something like Id.
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998
Printing of Core syntax
-}
module GHC.Core.Ppr (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
pprCoreBinder, pprCoreBinders, pprId, pprIds,
pprRule, pprRules, pprOptCo,
pprOcc, pprOccWithTick
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Stats (exprStats)
import GHC.Types.Fixity (LexicalFixity(..))
import GHC.Types.Literal( pprLiteral )
import GHC.Types.Name( pprInfixName, pprPrefixName )
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCo.Ppr
import GHC.Core.Coercion
import GHC.Types.Basic
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.SrcLoc ( pprUserRealSpan )
import GHC.Types.Tickish
{-
************************************************************************
* *
\subsection{Public interfaces for Core printing (excluding instances)}
* *
************************************************************************
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
-}
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 noAnn
pprCoreBinding = pprTopBind noAnn
pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingsWithSize = pprTopBinds sizeAnn
pprCoreBindingWithSize = pprTopBind sizeAnn
instance OutputableBndr b => Outputable (Bind b) where
ppr bind = ppr_bind noAnn bind
instance OutputableBndr b => Outputable (Expr b) where
ppr expr = pprCoreExpr expr
instance OutputableBndr b => Outputable (Alt b) where
ppr expr = pprCoreAlt expr
{-
************************************************************************
* *
\subsection{The guts}
* *
************************************************************************
-}
-- | A function to produce an annotation for a given right-hand-side
type Annotation b = Expr b -> SDoc
-- | Annotate with the size of the right-hand-side
sizeAnn :: CoreExpr -> SDoc
sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)
-- | No annotation
noAnn :: Expr b -> SDoc
noAnn _ = empty
pprTopBinds :: OutputableBndr a
=> Annotation a -- ^ generate an annotation to place before the
-- binding
-> [Bind a] -- ^ bindings to show
-> SDoc -- ^ the pretty result
pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)
pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind ann (NonRec binder expr)
= ppr_binding ann (binder,expr) $$ blankLine
pprTopBind _ (Rec [])
= text "Rec { }"
pprTopBind ann (Rec (b:bs))
= vcat [text "Rec {",
ppr_binding ann b,
vcat [blankLine $$ ppr_binding ann b | b <- bs],
text "end Rec }",
blankLine]
ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc
ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)
ppr_bind ann (Rec binds) = vcat (map pp binds)
where
pp bind = ppr_binding ann bind <> semi
ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding ann (val_bdr, expr)
= vcat [ ann expr
, ppUnlessOption sdocSuppressTypeSignatures
(pprBndr LetBind val_bdr)
, pp_bind
]
where
pp_val_bdr = pprPrefixOcc val_bdr
pp_bind = case bndrIsJoin_maybe val_bdr of
NotJoinPoint -> pp_normal_bind
JoinPoint ar -> pp_join_bind ar
pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
-- For a join point of join arity n, we want to print j = \x1 ... xn -> e
-- as "j x1 ... xn = e" to differentiate when a join point returns a
-- lambda (the first rendering looks like a nullary join point returning
-- an n-argument function).
pp_join_bind join_arity
| bndrs `lengthAtLeast` join_arity
= hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
2 (equals <+> pprCoreExpr rhs)
| otherwise -- Yikes! A join-binding with too few lambda
-- Lint will complain, but we don't want to crash
-- the pretty-printer else we can't see what's wrong
-- So refer to printing j = e
= pp_normal_bind
where
(bndrs, body) = collectBinders expr
(lhs_bndrs, rest) = splitAt join_arity bndrs
rhs = mkLams rest body
pprParendExpr expr = ppr_expr parens expr
pprCoreExpr expr = ppr_expr noParens expr
noParens :: SDoc -> SDoc
noParens pp = pp
pprOptCo :: Coercion -> SDoc
-- Print a coercion optionally; i.e. honouring -dsuppress-coercions
pprOptCo co = sdocOption sdocSuppressCoercions $ \case
True -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type
False -> parens $ sep [ppr co, dcolon <+> co_type]
where
co_type = sdocOption sdocSuppressCoercionTypes $ \case
True -> text "..."
False -> ppr (coercionType co)
ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ add_par id
| isJoinId id = add_par ((text "jump") <+> pp_id)
| otherwise = pp_id
where
pp_id = ppr id -- We could use pprPrefixOcc to print (+) etc, but this is
-- Core where we don't print things infix anyway, so doing
-- so just adds extra redundant parens
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 (Var id) = ppr_id_occ add_par id
ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird
ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
ppr_expr add_par (Lit lit) = pprLiteral add_par lit
ppr_expr add_par (Cast expr co)
= add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co]
ppr_expr add_par expr@(Lam _ _)
= let
(bndrs, body) = collectBinders expr
in
add_par $
hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (pprCoreExpr body)
ppr_expr add_par expr@(App {})
= sdocOption sdocSuppressTypeApplications $ \supp_ty_app ->
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 = pprWithCommas pprCoreExpr val_args
args'
| supp_ty_app = val_args
| otherwise = args
parens
| null args' = id
| otherwise = add_par
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
, Just sort <- tyConTuple_maybe tc
-> tupleParens sort pp_tup_args
where
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
_ -> parens (hang fun_doc 2 pp_args)
where
fun_doc = ppr_id_occ noParens f
_ -> parens (hang (pprParendExpr fun) 2 pp_args)
}
ppr_expr add_par (Case expr _ ty []) -- Empty Case
= add_par $ sep [text "case"
<+> pprCoreExpr expr
<+> whenPprDebug (text "return" <+> ppr ty),
text "of {}"]
ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case
= sdocOption sdocPrintCaseAsLet $ \case
True -> add_par $ -- See Note [Print case as let]
sep [ sep [ text "let! {"
<+> ppr_case_pat con args
<+> text "~"
<+> ppr_bndr var
, text "<-" <+> ppr_expr id expr
<+> text "} in" ]
, pprCoreExpr rhs
]
False -> add_par $
sep [sep [sep [ text "case" <+> pprCoreExpr expr
, whenPprDebug (text "return" <+> ppr ty)
, text "of" <+> ppr_bndr var
]
, char '{' <+> ppr_case_pat con args <+> arrow
]
, pprCoreExpr rhs
, char '}'
]
where
ppr_bndr = pprBndr CaseBind
ppr_expr add_par (Case expr var ty alts) -- Multi alt Case
= add_par $
sep [sep [text "case"
<+> pprCoreExpr expr
<+> whenPprDebug (text "return" <+> ppr ty),
text "of" <+> ppr_bndr var <+> char '{'],
nest 2 (vcat (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 [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
nest 2 (pprCoreExpr rhs),
text "} in",
pprCoreExpr body ]
ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
= add_par
(hang (text "let {")
2 (hsep [ppr_binding (val_bdr,rhs),
text "} in"])
$$
pprCoreExpr expr)
-}
-- General case (recursive case, too)
ppr_expr add_par (Let bind expr)
= add_par $
sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),
pprCoreExpr expr]
where
keyword (NonRec b _)
| isJoinPoint (bndrIsJoin_maybe b) = text "join"
| otherwise = text "let"
keyword (Rec pairs)
| ((b,_):_) <- pairs
, isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"
| otherwise = text "letrec"
ppr_expr add_par (Tick tickish expr)
= sdocOption sdocSuppressTicks $ \case
-- Only hide non-runtime relevant ticks.
True
| not (tickishIsCode tickish) -> ppr_expr add_par expr
_ -> add_par (sep [ppr tickish, pprCoreExpr expr])
pprCoreAlt :: OutputableBndr a => Alt a -> SDoc
pprCoreAlt (Alt con args rhs)
= hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt dc) args
| Just sort <- tyConTuple_maybe tc
= tupleParens sort (pprWithCommas ppr_bndr args)
where
ppr_bndr = pprBndr CasePatBind
tc = dataConTyCon dc
ppr_case_pat con args
= ppr con <+> (fsep (map ppr_bndr args))
where
ppr_bndr = pprBndr CasePatBind
-- | Pretty print the argument in a function application.
pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty)
= ppUnlessOption sdocSuppressTypeApplications
(text "@" <> pprParendType ty)
pprArg (Coercion co) = text "@~" <> pprOptCo co
pprArg expr = pprParendExpr expr
{-
Note [Print case as let]
~~~~~~~~~~~~~~~~~~~~~~~~
Single-branch case expressions are very common:
case x of y { I# x' ->
case p of q { I# p' -> ... } }
These are, in effect, just strict let's, with pattern matching.
With -dppr-case-as-let we print them as such:
let! { I# x' ~ y <- x } in
let! { I# p' ~ q <- p } in ...
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
Note [Binding-site specific printing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust
the information printed.
Let-bound binders are printed with their full type and idInfo.
Case-bound variables (both the case binder and pattern variables) are printed
without a type and without their unfolding.
Furthermore, a dead case-binder is completely ignored, while otherwise, dead
binders are printed as "_".
-}
-- These instances are sadly orphans
instance OutputableBndr Var where
pprBndr = pprCoreBinder
pprInfixOcc = pprInfixName . varName
pprPrefixOcc = pprPrefixName . varName
bndrIsJoin_maybe = idJoinPointHood
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b
bndrIsJoin_maybe (TB b _) = idJoinPointHood b
pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc Infix = pprInfixOcc
pprOcc Prefix = pprPrefixOcc
pprOccWithTick :: OutputableBndr a => LexicalFixity -> PromotionFlag -> a -> SDoc
pprOccWithTick fixity prom op
| isPromoted prom
= quote (pprOcc fixity op)
| otherwise
= pprOcc fixity op
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
| isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedLetBinder binder $$
ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
pprCoreBinder bind_site bndr
= getPprDebug $ \debug ->
pprTypedLamBinder bind_site debug bndr
pprCoreBinders :: [Var] -> SDoc
-- Print as lambda-binders, i.e. with their type
pprCoreBinders vs = sep (map (pprCoreBinder LambdaBind) vs)
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
| isTyVar binder = text "@" <> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
-- For lambda and case binders, show the unfolding info (usually none)
pprTypedLamBinder bind_site debug_on var
= sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
case () of
_
| not debug_on -- Show case-bound wild binders only if debug is on
, CaseBind <- bind_site
, isDeadBinder var -> empty
| not debug_on -- Even dead binders can be one-shot
, isDeadBinder var -> char '_' <+> ppWhen (isId var)
(pprIdBndrInfo (idInfo var))
| not debug_on -- No parens, no kind info
, CaseBind <- bind_site -> pprUntypedBinder var
| not debug_on
, CasePatBind <- bind_site -> pprUntypedBinder var
| suppress_sigs -> pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
| otherwise -> parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var)
, pp_unf]))
where
unf_info = realUnfoldingInfo (idInfo var)
pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info
| otherwise = empty
pprTypedLetBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedLetBinder binder
= sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
case () of
_
| isTyVar binder -> pprKindedTyVarBndr binder
| suppress_sigs -> pprIdBndr binder
| otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr tyvar
= text "@" <> pprTyVar tyvar
-- pprId x prints x :: ty
pprId :: Id -> SDoc
pprId x = ppr x <+> dcolon <+> ppr (idType x)
pprIds :: [Id] -> SDoc
pprIds xs = sep (map pprId xs)
-- 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 -> SDoc
pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
= ppUnlessOption sdocSuppressIdInfo
(info `seq` doc) -- The seq is useful for poking on black holes
where
prag_info = inlinePragInfo info
occ_info = occInfo info
dmd_info = demandInfo info
lbv_info = oneShotInfo info
has_prag = not (isDefaultInlinePragma prag_info)
has_occ = not (isNoOccInfo occ_info)
has_dmd = not $ isTopDmd dmd_info
has_lbv = not (hasNoOneShotInfo lbv_info)
doc = showAttributes
[ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
, (has_occ, text "Occ=" <> ppr occ_info)
, (has_dmd, text "Dmd=" <> ppr dmd_info)
, (has_lbv , text "OS=" <> ppr lbv_info)
]
instance Outputable IdInfo where
ppr info = showAttributes
[ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)
, (has_occ, text "Occ=" <> ppr occ_info)
, (has_dmd, text "Dmd=" <> ppr dmd_info)
, (has_lbv , text "OS=" <> ppr lbv_info)
, (has_arity, text "Arity=" <> int arity)
, (has_called_arity, text "CallArity=" <> int called_arity)
, (has_caf_info, text "Caf=" <> ppr caf_info)
, (has_str_info, text "Str=" <> pprStrictness str_info)
, (has_unf, text "Unf=" <> ppr unf_info)
, (has_rules, text "RULES:" <+> vcat (map pprRule rules))
]
where
prag_info = inlinePragInfo info
has_prag = not (isDefaultInlinePragma prag_info)
occ_info = occInfo info
has_occ = not (isManyOccs occ_info)
dmd_info = demandInfo info
has_dmd = not $ isTopDmd dmd_info
lbv_info = oneShotInfo info
has_lbv = not (hasNoOneShotInfo lbv_info)
arity = arityInfo info
has_arity = arity /= 0
called_arity = callArityInfo info
has_called_arity = called_arity /= 0
caf_info = cafInfo info
has_caf_info = not (mayHaveCafRefs caf_info)
str_info = dmdSigInfo info
has_str_info = not (isNopSig str_info)
unf_info = realUnfoldingInfo info
has_unf = hasSomeUnfolding unf_info
rules = ruleInfoRules (ruleInfo info)
has_rules = not (null rules)
{-
-----------------------------------------------------
-- IdDetails and IdInfo
-----------------------------------------------------
-}
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo id info
= ppUnlessOption sdocSuppressIdInfo $
showAttributes
[ (True, pp_scope <> ppr (idDetails id))
, (has_arity, text "Arity=" <> int arity)
, (has_called_arity, text "CallArity=" <> int called_arity)
, (has_caf_info, text "Caf=" <> ppr caf_info)
, (has_str_info, text "Str=" <> pprStrictness str_info)
, (has_cpr_info, text "Cpr=" <> ppr cpr_info)
, (has_unf, text "Unf=" <> ppr unf_info)
, (not (null rules), text "RULES:" <+> vcat (map pprRule rules))
] -- Inline pragma, occ, demand, one-shot info
-- printed out with all binders (when debug is on);
-- see GHC.Core.Ppr.pprIdBndr
where
pp_scope | isGlobalId id = text "GblId"
| isExportedId id = text "LclIdX"
| otherwise = text "LclId"
arity = arityInfo info
has_arity = arity /= 0
called_arity = callArityInfo info
has_called_arity = called_arity /= 0
caf_info = cafInfo info
has_caf_info = not (mayHaveCafRefs caf_info)
str_info = dmdSigInfo info
has_str_info = not (isNopSig str_info)
cpr_info = cprSigInfo info
has_cpr_info = cpr_info /= topCprSig
unf_info = realUnfoldingInfo info
has_unf = hasSomeUnfolding unf_info
rules = ruleInfoRules (ruleInfo info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes stuff
| null docs = empty
| otherwise = brackets (sep (punctuate comma docs))
where
docs = [d | (True,d) <- stuff]
{-
-----------------------------------------------------
-- Unfolding and UnfoldingGuidance
-----------------------------------------------------
-}
instance Outputable UnfoldingGuidance where
ppr UnfNever = text "NEVER"
ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
= text "ALWAYS_IF" <>
parens (text "arity=" <> int arity <> comma <>
text "unsat_ok=" <> ppr unsat_ok <> comma <>
text "boring_ok=" <> ppr boring_ok)
ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
= hsep [ text "IF_ARGS",
brackets (hsep (map int cs)),
int size,
int discount ]
instance Outputable Unfolding where
ppr NoUnfolding = text "No unfolding"
ppr BootUnfolding = text "No unfolding (from boot)"
ppr (OtherCon cs) = text "OtherCon" <+> ppr cs
ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
= hang (text "DFun:" <+> char '\\'
<+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (ppr con <+> sep (map ppr args))
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top
, uf_cache=cache, uf_guidance=g })
= text "Unf" <> braces (pp_info $$ pp_rhs)
where
pp_info = fsep $ punctuate comma
[ text "Src=" <> ppr src
, text "TopLvl=" <> ppr top
, ppr cache
, text "Guidance=" <> ppr g ]
pp_tmpl = ppUnlessOption sdocSuppressUnfoldings
(text "Tmpl=" <+> ppr rhs)
pp_rhs | isStableSource src = pp_tmpl
| otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
instance Outputable UnfoldingCache where
ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
, uf_is_work_free = wf, uf_expandable = exp })
= fsep $ punctuate comma
[ text "Value=" <> ppr hnf
, text "ConLike=" <> ppr conlike
, text "WorkFree=" <> ppr wf
, text "Expandable=" <> ppr exp ]
{-
-----------------------------------------------------
-- Rules
-----------------------------------------------------
-}
instance Outputable CoreRule where
ppr = pprRule
pprRules :: [CoreRule] -> SDoc
pprRules rules = vcat (map pprRule rules)
pprRule :: CoreRule -> SDoc
pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
= text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)
pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
ru_bndrs = tpl_vars, ru_args = tpl_args,
ru_rhs = rhs })
= hang (doubleQuotes (ftext name) <+> ppr act)
4 (sep [text "forall" <+> pprCoreBinders tpl_vars <> dot,
nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
nest 2 (text "=" <+> pprCoreExpr rhs)
])
{-
-----------------------------------------------------
-- Tickish
-----------------------------------------------------
-}
instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
ppr (HpcTick modl ix) =
hcat [text "hpc<",
ppr modl, comma,
ppr ix,
text ">"]
ppr (Breakpoint _ext bid vars) =
hcat [text "break<",
ppr (bi_tick_mod bid), comma,
ppr (bi_tick_index bid),
text ">",
parens (hcat (punctuate comma (map ppr vars)))]
ppr (ProfNote { profNoteCC = cc,
profNoteCount = tick,
profNoteScope = scope }) =
case (tick,scope) of
(True,True) -> hcat [text "scctick<", ppr cc, char '>']
(True,False) -> hcat [text "tick<", ppr cc, char '>']
_ -> hcat [text "scc<", ppr cc, char '>']
ppr (SourceNote span _) =
hcat [ text "src<", pprUserRealSpan True span, char '>']