{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Core.Ppr (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
pprCoreBinder, pprCoreBinders,
pprRules, pprOptCo
) where
import GHC.Prelude
import GHC.Core
import GHC.Core.Stats (exprStats)
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.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.SrcLoc ( pprUserRealSpan )
import GHC.Types.Tickish
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 :: forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings = forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds forall b. Expr b -> SDoc
noAnn
pprCoreBinding :: forall b. OutputableBndr b => Bind b -> SDoc
pprCoreBinding = forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind forall b. Expr b -> SDoc
noAnn
pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingsWithSize = forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds CoreExpr -> SDoc
sizeAnn
pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingWithSize = forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind CoreExpr -> SDoc
sizeAnn
instance OutputableBndr b => Outputable (Bind b) where
ppr :: Bind b -> SDoc
ppr Bind b
bind = forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
ppr_bind forall b. Expr b -> SDoc
noAnn Bind b
bind
instance OutputableBndr b => Outputable (Expr b) where
ppr :: Expr b -> SDoc
ppr Expr b
expr = forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr
instance OutputableBndr b => Outputable (Alt b) where
ppr :: Alt b -> SDoc
ppr Alt b
expr = forall b. OutputableBndr b => Alt b -> SDoc
pprCoreAlt Alt b
expr
type Annotation b = Expr b -> SDoc
sizeAnn :: CoreExpr -> SDoc
sizeAnn :: CoreExpr -> SDoc
sizeAnn CoreExpr
e = String -> SDoc
text String
"-- RHS size:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (CoreExpr -> CoreStats
exprStats CoreExpr
e)
noAnn :: Expr b -> SDoc
noAnn :: forall b. Expr b -> SDoc
noAnn Expr b
_ = SDoc
empty
pprTopBinds :: OutputableBndr a
=> Annotation a
-> [Bind a]
-> SDoc
pprTopBinds :: forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds Annotation a
ann [Bind a]
binds = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind Annotation a
ann) [Bind a]
binds)
pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind :: forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind Annotation a
ann (NonRec a
binder Expr a
expr)
= forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation a
ann (a
binder,Expr a
expr) SDoc -> SDoc -> SDoc
$$ SDoc
blankLine
pprTopBind Annotation a
_ (Rec [])
= String -> SDoc
text String
"Rec { }"
pprTopBind Annotation a
ann (Rec ((a, Expr a)
b:[(a, Expr a)]
bs))
= [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Rec {",
forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation a
ann (a, Expr a)
b,
[SDoc] -> SDoc
vcat [SDoc
blankLine SDoc -> SDoc -> SDoc
$$ forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation a
ann (a, Expr a)
b | (a, Expr a)
b <- [(a, Expr a)]
bs],
String -> SDoc
text String
"end Rec }",
SDoc
blankLine]
ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc
ppr_bind :: forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
ppr_bind Annotation b
ann (NonRec b
val_bdr Expr b
expr) = forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation b
ann (b
val_bdr, Expr b
expr)
ppr_bind Annotation b
ann (Rec [(b, Expr b)]
binds) = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (b, Expr b) -> SDoc
pp [(b, Expr b)]
binds)
where
pp :: (b, Expr b) -> SDoc
pp (b, Expr b)
bind = forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation b
ann (b, Expr b)
bind SDoc -> SDoc -> SDoc
<> SDoc
semi
ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding :: forall b. OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding Annotation b
ann (b
val_bdr, Expr b
expr)
= [SDoc] -> SDoc
vcat [ Annotation b
ann Expr b
expr
, (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTypeSignatures
(forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind b
val_bdr)
, SDoc
pp_bind
]
where
pp_val_bdr :: SDoc
pp_val_bdr = forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc b
val_bdr
pp_bind :: SDoc
pp_bind = case forall a. OutputableBndr a => a -> Maybe ArityInfo
bndrIsJoin_maybe b
val_bdr of
Maybe ArityInfo
Nothing -> SDoc
pp_normal_bind
Just ArityInfo
ar -> ArityInfo -> SDoc
pp_join_bind ArityInfo
ar
pp_normal_bind :: SDoc
pp_normal_bind = SDoc -> ArityInfo -> SDoc -> SDoc
hang SDoc
pp_val_bdr ArityInfo
2 (SDoc
equals SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr)
pp_join_bind :: ArityInfo -> SDoc
pp_join_bind ArityInfo
join_arity
| [b]
bndrs forall a. [a] -> ArityInfo -> Bool
`lengthAtLeast` ArityInfo
join_arity
= SDoc -> ArityInfo -> SDoc -> SDoc
hang (SDoc
pp_val_bdr SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [b]
lhs_bndrs))
ArityInfo
2 (SDoc
equals SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs)
| Bool
otherwise
= SDoc
pp_normal_bind
where
([b]
bndrs, Expr b
body) = forall b. Expr b -> ([b], Expr b)
collectBinders Expr b
expr
lhs_bndrs :: [b]
lhs_bndrs = forall a. ArityInfo -> [a] -> [a]
take ArityInfo
join_arity [b]
bndrs
rhs :: Expr b
rhs = forall b. [b] -> Expr b -> Expr b
mkLams (forall a. ArityInfo -> [a] -> [a]
drop ArityInfo
join_arity [b]
bndrs) Expr b
body
pprParendExpr :: forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr Expr b
expr = forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
parens Expr b
expr
pprCoreExpr :: forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr = forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
noParens Expr b
expr
noParens :: SDoc -> SDoc
noParens :: SDoc -> SDoc
noParens SDoc
pp = SDoc
pp
pprOptCo :: Coercion -> SDoc
pprOptCo :: Coercion -> SDoc
pprOptCo Coercion
co = forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressCoercions forall a b. (a -> b) -> a -> b
$ \case
Bool
True -> SDoc -> SDoc
angleBrackets (String -> SDoc
text String
"Co:" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int (Coercion -> ArityInfo
coercionSize Coercion
co))
Bool
False -> SDoc -> SDoc
parens forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep [forall a. Outputable a => a -> SDoc
ppr Coercion
co, SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)]
ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ SDoc -> SDoc
add_par Id
id
| Id -> Bool
isJoinId Id
id = SDoc -> SDoc
add_par ((String -> SDoc
text String
"jump") SDoc -> SDoc -> SDoc
<+> SDoc
pp_id)
| Bool
otherwise = SDoc
pp_id
where
pp_id :: SDoc
pp_id = forall a. Outputable a => a -> SDoc
ppr Id
id
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr :: forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
add_par (Var Id
id) = (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ SDoc -> SDoc
add_par Id
id
ppr_expr SDoc -> SDoc
add_par (Type Type
ty) = SDoc -> SDoc
add_par (String -> SDoc
text String
"TYPE:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ty)
ppr_expr SDoc -> SDoc
add_par (Coercion Coercion
co) = SDoc -> SDoc
add_par (String -> SDoc
text String
"CO:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Coercion
co)
ppr_expr SDoc -> SDoc
add_par (Lit Literal
lit) = (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral SDoc -> SDoc
add_par Literal
lit
ppr_expr SDoc -> SDoc
add_par (Cast Expr b
expr Coercion
co)
= SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep [forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr Expr b
expr, String -> SDoc
text String
"`cast`" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
pprOptCo Coercion
co]
ppr_expr SDoc -> SDoc
add_par expr :: Expr b
expr@(Lam b
_ Expr b
_)
= let
([b]
bndrs, Expr b
body) = forall b. Expr b -> ([b], Expr b)
collectBinders Expr b
expr
in
SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$
SDoc -> ArityInfo -> SDoc -> SDoc
hang (String -> SDoc
text String
"\\" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [b]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow)
ArityInfo
2 (forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
body)
ppr_expr SDoc -> SDoc
add_par expr :: Expr b
expr@(App {})
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeApplications forall a b. (a -> b) -> a -> b
$ \Bool
supp_ty_app ->
case forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr b
expr of { (Expr b
fun, [Expr b]
args) ->
let
pp_args :: SDoc
pp_args = [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall b. OutputableBndr b => Expr b -> SDoc
pprArg [Expr b]
args)
val_args :: [Expr b]
val_args = forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall b. Expr b -> Bool
isTypeArg [Expr b]
args
pp_tup_args :: SDoc
pp_tup_args = forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr [Expr b]
val_args
args' :: [Expr b]
args'
| Bool
supp_ty_app = [Expr b]
val_args
| Bool
otherwise = [Expr b]
args
parens :: SDoc -> SDoc
parens
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr b]
args' = forall a. a -> a
id
| Bool
otherwise = SDoc -> SDoc
add_par
in
case Expr b
fun of
Var Id
f -> case Id -> Maybe DataCon
isDataConWorkId_maybe Id
f of
Just DataCon
dc | Bool
saturated
, Just TupleSort
sort <- TyCon -> Maybe TupleSort
tyConTuple_maybe TyCon
tc
-> TupleSort -> SDoc -> SDoc
tupleParens TupleSort
sort SDoc
pp_tup_args
where
tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
saturated :: Bool
saturated = [Expr b]
val_args forall a. [a] -> ArityInfo -> Bool
`lengthIs` Id -> ArityInfo
idArity Id
f
Maybe DataCon
_ -> SDoc -> SDoc
parens (SDoc -> ArityInfo -> SDoc -> SDoc
hang SDoc
fun_doc ArityInfo
2 SDoc
pp_args)
where
fun_doc :: SDoc
fun_doc = (SDoc -> SDoc) -> Id -> SDoc
ppr_id_occ SDoc -> SDoc
noParens Id
f
Expr b
_ -> SDoc -> SDoc
parens (SDoc -> ArityInfo -> SDoc -> SDoc
hang (forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr Expr b
fun) ArityInfo
2 SDoc
pp_args)
}
ppr_expr SDoc -> SDoc
add_par (Case Expr b
expr b
var Type
ty [Alt AltCon
con [b]
args Expr b
rhs])
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintCaseAsLet forall a b. (a -> b) -> a -> b
$ \case
Bool
True -> SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ [SDoc] -> SDoc
sep [ String -> SDoc
text String
"let! {"
SDoc -> SDoc -> SDoc
<+> forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat AltCon
con [b]
args
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"~"
SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var
, String -> SDoc
text String
"<-" SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr forall a. a -> a
id Expr b
expr
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"} in" ]
, forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs
]
Bool
False -> SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [ String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr
, SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"return" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ty)
, String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var
]
, Char -> SDoc
char Char
'{' SDoc -> SDoc -> SDoc
<+> forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat AltCon
con [b]
args SDoc -> SDoc -> SDoc
<+> SDoc
arrow
]
, forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs
, Char -> SDoc
char Char
'}'
]
where
ppr_bndr :: b -> SDoc
ppr_bndr = forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CaseBind
ppr_expr SDoc -> SDoc
add_par (Case Expr b
expr b
var Type
ty [Alt b]
alts)
= SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [String -> SDoc
text String
"case"
SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"return" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ty),
String -> SDoc
text String
"of" SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'{'],
ArityInfo -> SDoc -> SDoc
nest ArityInfo
2 ([SDoc] -> SDoc
vcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
semi (forall a b. (a -> b) -> [a] -> [b]
map forall b. OutputableBndr b => Alt b -> SDoc
pprCoreAlt [Alt b]
alts))),
Char -> SDoc
char Char
'}'
]
where
ppr_bndr :: b -> SDoc
ppr_bndr = forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CaseBind
ppr_expr SDoc -> SDoc
add_par (Let Bind b
bind Expr b
expr)
= SDoc -> SDoc
add_par forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [SDoc -> ArityInfo -> SDoc -> SDoc
hang (forall b. OutputableBndr b => Bind b -> SDoc
keyword Bind b
bind SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'{') ArityInfo
2 (forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
ppr_bind forall b. Expr b -> SDoc
noAnn Bind b
bind SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"} in"),
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr]
where
keyword :: Bind a -> SDoc
keyword (NonRec a
b Expr a
_)
| forall a. Maybe a -> Bool
isJust (forall a. OutputableBndr a => a -> Maybe ArityInfo
bndrIsJoin_maybe a
b) = String -> SDoc
text String
"join"
| Bool
otherwise = String -> SDoc
text String
"let"
keyword (Rec [(a, Expr a)]
pairs)
| ((a
b,Expr a
_):[(a, Expr a)]
_) <- [(a, Expr a)]
pairs
, forall a. Maybe a -> Bool
isJust (forall a. OutputableBndr a => a -> Maybe ArityInfo
bndrIsJoin_maybe a
b) = String -> SDoc
text String
"joinrec"
| Bool
otherwise = String -> SDoc
text String
"letrec"
ppr_expr SDoc -> SDoc
add_par (Tick CoreTickish
tickish Expr b
expr)
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTicks forall a b. (a -> b) -> a -> b
$ \case
Bool
True -> forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
add_par Expr b
expr
Bool
False -> SDoc -> SDoc
add_par ([SDoc] -> SDoc
sep [forall a. Outputable a => a -> SDoc
ppr CoreTickish
tickish, forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr])
pprCoreAlt :: OutputableBndr a => Alt a -> SDoc
pprCoreAlt :: forall b. OutputableBndr b => Alt b -> SDoc
pprCoreAlt (Alt AltCon
con [a]
args Expr a
rhs)
= SDoc -> ArityInfo -> SDoc -> SDoc
hang (forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat AltCon
con [a]
args SDoc -> SDoc -> SDoc
<+> SDoc
arrow) ArityInfo
2 (forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr a
rhs)
ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat :: forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt DataCon
dc) [a]
args
| Just TupleSort
sort <- TyCon -> Maybe TupleSort
tyConTuple_maybe TyCon
tc
= TupleSort -> SDoc -> SDoc
tupleParens TupleSort
sort (forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas a -> SDoc
ppr_bndr [a]
args)
where
ppr_bndr :: a -> SDoc
ppr_bndr = forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CasePatBind
tc :: TyCon
tc = DataCon -> TyCon
dataConTyCon DataCon
dc
ppr_case_pat AltCon
con [a]
args
= forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
fsep (forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
ppr_bndr [a]
args))
where
ppr_bndr :: a -> SDoc
ppr_bndr = forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CasePatBind
pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg :: forall b. OutputableBndr b => Expr b -> SDoc
pprArg (Type Type
ty)
= (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressTypeApplications
(String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> Type -> SDoc
pprParendType Type
ty)
pprArg (Coercion Coercion
co) = String -> SDoc
text String
"@~" SDoc -> SDoc -> SDoc
<> Coercion -> SDoc
pprOptCo Coercion
co
pprArg Expr a
expr = forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr Expr a
expr
instance OutputableBndr Var where
pprBndr :: BindingSite -> Id -> SDoc
pprBndr = BindingSite -> Id -> SDoc
pprCoreBinder
pprInfixOcc :: Id -> SDoc
pprInfixOcc = forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
varName
pprPrefixOcc :: Id -> SDoc
pprPrefixOcc = forall a. NamedThing a => a -> SDoc
pprPrefixName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
varName
bndrIsJoin_maybe :: Id -> Maybe ArityInfo
bndrIsJoin_maybe = Id -> Maybe ArityInfo
isJoinId_maybe
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr :: BindingSite -> TaggedBndr b -> SDoc
pprBndr BindingSite
_ TaggedBndr b
b = forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
pprInfixOcc :: TaggedBndr b -> SDoc
pprInfixOcc TaggedBndr b
b = forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
pprPrefixOcc :: TaggedBndr b -> SDoc
pprPrefixOcc TaggedBndr b
b = forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
bndrIsJoin_maybe :: TaggedBndr b -> Maybe ArityInfo
bndrIsJoin_maybe (TB Id
b b
_) = Id -> Maybe ArityInfo
isJoinId_maybe Id
b
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder :: BindingSite -> Id -> SDoc
pprCoreBinder BindingSite
LetBind Id
binder
| Id -> Bool
isTyVar Id
binder = Id -> SDoc
pprKindedTyVarBndr Id
binder
| Bool
otherwise = Id -> SDoc
pprTypedLetBinder Id
binder SDoc -> SDoc -> SDoc
$$
Id -> IdInfo -> SDoc
ppIdInfo Id
binder (HasDebugCallStack => Id -> IdInfo
idInfo Id
binder)
pprCoreBinder BindingSite
bind_site Id
bndr
= (Bool -> SDoc) -> SDoc
getPprDebug forall a b. (a -> b) -> a -> b
$ \Bool
debug ->
BindingSite -> Bool -> Id -> SDoc
pprTypedLamBinder BindingSite
bind_site Bool
debug Id
bndr
pprCoreBinders :: [Var] -> SDoc
pprCoreBinders :: [Id] -> SDoc
pprCoreBinders [Id]
vs = [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Id -> SDoc
pprCoreBinder BindingSite
LambdaBind) [Id]
vs)
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder :: Id -> SDoc
pprUntypedBinder Id
binder
| Id -> Bool
isTyVar Id
binder = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
binder
| Bool
otherwise = Id -> SDoc
pprIdBndr Id
binder
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
pprTypedLamBinder :: BindingSite -> Bool -> Id -> SDoc
pprTypedLamBinder BindingSite
bind_site Bool
debug_on Id
var
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeSignatures forall a b. (a -> b) -> a -> b
$ \Bool
suppress_sigs ->
case () of
()
_
| Bool -> Bool
not Bool
debug_on
, BindingSite
CaseBind <- BindingSite
bind_site
, Id -> Bool
isDeadBinder Id
var -> SDoc
empty
| Bool -> Bool
not Bool
debug_on
, Id -> Bool
isDeadBinder Id
var -> Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<+> Bool -> SDoc -> SDoc
ppWhen (Id -> Bool
isId Id
var)
(IdInfo -> SDoc
pprIdBndrInfo (HasDebugCallStack => Id -> IdInfo
idInfo Id
var))
| Bool -> Bool
not Bool
debug_on
, BindingSite
CaseBind <- BindingSite
bind_site -> Id -> SDoc
pprUntypedBinder Id
var
| Bool -> Bool
not Bool
debug_on
, BindingSite
CasePatBind <- BindingSite
bind_site -> Id -> SDoc
pprUntypedBinder Id
var
| Bool
suppress_sigs -> Id -> SDoc
pprUntypedBinder Id
var
| Id -> Bool
isTyVar Id
var -> SDoc -> SDoc
parens (Id -> SDoc
pprKindedTyVarBndr Id
var)
| Bool
otherwise -> SDoc -> SDoc
parens (SDoc -> ArityInfo -> SDoc -> SDoc
hang (Id -> SDoc
pprIdBndr Id
var)
ArityInfo
2 ([SDoc] -> SDoc
vcat [ SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Id -> Type
idType Id
var)
, SDoc
pp_unf]))
where
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo (HasDebugCallStack => Id -> IdInfo
idInfo Id
var)
pp_unf :: SDoc
pp_unf | Unfolding -> Bool
hasSomeUnfolding Unfolding
unf_info = String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Unfolding
unf_info
| Bool
otherwise = SDoc
empty
pprTypedLetBinder :: Var -> SDoc
pprTypedLetBinder :: Id -> SDoc
pprTypedLetBinder Id
binder
= forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeSignatures forall a b. (a -> b) -> a -> b
$ \Bool
suppress_sigs ->
case () of
()
_
| Id -> Bool
isTyVar Id
binder -> Id -> SDoc
pprKindedTyVarBndr Id
binder
| Bool
suppress_sigs -> Id -> SDoc
pprIdBndr Id
binder
| Bool
otherwise -> SDoc -> ArityInfo -> SDoc -> SDoc
hang (Id -> SDoc
pprIdBndr Id
binder) ArityInfo
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Id -> Type
idType Id
binder))
pprKindedTyVarBndr :: TyVar -> SDoc
pprKindedTyVarBndr :: Id -> SDoc
pprKindedTyVarBndr Id
tyvar
= String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> Id -> SDoc
pprTyVar Id
tyvar
pprIdBndr :: Id -> SDoc
pprIdBndr :: Id -> SDoc
pprIdBndr Id
id = forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Id
id SDoc -> SDoc -> SDoc
<+> IdInfo -> SDoc
pprIdBndrInfo (HasDebugCallStack => Id -> IdInfo
idInfo Id
id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo IdInfo
info
= (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressIdInfo
(IdInfo
info seq :: forall a b. a -> b -> b
`seq` SDoc
doc)
where
prag_info :: InlinePragma
prag_info = IdInfo -> InlinePragma
inlinePragInfo IdInfo
info
occ_info :: OccInfo
occ_info = IdInfo -> OccInfo
occInfo IdInfo
info
dmd_info :: Demand
dmd_info = IdInfo -> Demand
demandInfo IdInfo
info
lbv_info :: OneShotInfo
lbv_info = IdInfo -> OneShotInfo
oneShotInfo IdInfo
info
has_prag :: Bool
has_prag = Bool -> Bool
not (InlinePragma -> Bool
isDefaultInlinePragma InlinePragma
prag_info)
has_occ :: Bool
has_occ = Bool -> Bool
not (OccInfo -> Bool
isNoOccInfo OccInfo
occ_info)
has_dmd :: Bool
has_dmd = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Demand -> Bool
isTopDmd Demand
dmd_info
has_lbv :: Bool
has_lbv = Bool -> Bool
not (OneShotInfo -> Bool
hasNoOneShotInfo OneShotInfo
lbv_info)
doc :: SDoc
doc = [(Bool, SDoc)] -> SDoc
showAttributes
[ (Bool
has_prag, String -> SDoc
text String
"InlPrag=" SDoc -> SDoc -> SDoc
<> InlinePragma -> SDoc
pprInlineDebug InlinePragma
prag_info)
, (Bool
has_occ, String -> SDoc
text String
"Occ=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr OccInfo
occ_info)
, (Bool
has_dmd, String -> SDoc
text String
"Dmd=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Demand
dmd_info)
, (Bool
has_lbv , String -> SDoc
text String
"OS=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr OneShotInfo
lbv_info)
]
instance Outputable IdInfo where
ppr :: IdInfo -> SDoc
ppr IdInfo
info = [(Bool, SDoc)] -> SDoc
showAttributes
[ (Bool
has_prag, String -> SDoc
text String
"InlPrag=" SDoc -> SDoc -> SDoc
<> InlinePragma -> SDoc
pprInlineDebug InlinePragma
prag_info)
, (Bool
has_occ, String -> SDoc
text String
"Occ=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr OccInfo
occ_info)
, (Bool
has_dmd, String -> SDoc
text String
"Dmd=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Demand
dmd_info)
, (Bool
has_lbv , String -> SDoc
text String
"OS=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr OneShotInfo
lbv_info)
, (Bool
has_arity, String -> SDoc
text String
"Arity=" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int ArityInfo
arity)
, (Bool
has_called_arity, String -> SDoc
text String
"CallArity=" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int ArityInfo
called_arity)
, (Bool
has_caf_info, String -> SDoc
text String
"Caf=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr CafInfo
caf_info)
, (Bool
has_str_info, String -> SDoc
text String
"Str=" SDoc -> SDoc -> SDoc
<> StrictSig -> SDoc
pprStrictness StrictSig
str_info)
, (Bool
has_unf, String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Unfolding
unf_info)
, (Bool
has_rules, String -> SDoc
text String
"RULES:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> SDoc
pprRule [CoreRule]
rules))
]
where
prag_info :: InlinePragma
prag_info = IdInfo -> InlinePragma
inlinePragInfo IdInfo
info
has_prag :: Bool
has_prag = Bool -> Bool
not (InlinePragma -> Bool
isDefaultInlinePragma InlinePragma
prag_info)
occ_info :: OccInfo
occ_info = IdInfo -> OccInfo
occInfo IdInfo
info
has_occ :: Bool
has_occ = Bool -> Bool
not (OccInfo -> Bool
isManyOccs OccInfo
occ_info)
dmd_info :: Demand
dmd_info = IdInfo -> Demand
demandInfo IdInfo
info
has_dmd :: Bool
has_dmd = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Demand -> Bool
isTopDmd Demand
dmd_info
lbv_info :: OneShotInfo
lbv_info = IdInfo -> OneShotInfo
oneShotInfo IdInfo
info
has_lbv :: Bool
has_lbv = Bool -> Bool
not (OneShotInfo -> Bool
hasNoOneShotInfo OneShotInfo
lbv_info)
arity :: ArityInfo
arity = IdInfo -> ArityInfo
arityInfo IdInfo
info
has_arity :: Bool
has_arity = ArityInfo
arity forall a. Eq a => a -> a -> Bool
/= ArityInfo
0
called_arity :: ArityInfo
called_arity = IdInfo -> ArityInfo
callArityInfo IdInfo
info
has_called_arity :: Bool
has_called_arity = ArityInfo
called_arity forall a. Eq a => a -> a -> Bool
/= ArityInfo
0
caf_info :: CafInfo
caf_info = IdInfo -> CafInfo
cafInfo IdInfo
info
has_caf_info :: Bool
has_caf_info = Bool -> Bool
not (CafInfo -> Bool
mayHaveCafRefs CafInfo
caf_info)
str_info :: StrictSig
str_info = IdInfo -> StrictSig
strictnessInfo IdInfo
info
has_str_info :: Bool
has_str_info = Bool -> Bool
not (StrictSig -> Bool
isTopSig StrictSig
str_info)
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
has_unf :: Bool
has_unf = Unfolding -> Bool
hasSomeUnfolding Unfolding
unf_info
rules :: [CoreRule]
rules = RuleInfo -> [CoreRule]
ruleInfoRules (IdInfo -> RuleInfo
ruleInfo IdInfo
info)
has_rules :: Bool
has_rules = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules)
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo Id
id IdInfo
info
= (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressIdInfo forall a b. (a -> b) -> a -> b
$
[(Bool, SDoc)] -> SDoc
showAttributes
[ (Bool
True, SDoc
pp_scope SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (Id -> IdDetails
idDetails Id
id))
, (Bool
has_arity, String -> SDoc
text String
"Arity=" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int ArityInfo
arity)
, (Bool
has_called_arity, String -> SDoc
text String
"CallArity=" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int ArityInfo
called_arity)
, (Bool
has_caf_info, String -> SDoc
text String
"Caf=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr CafInfo
caf_info)
, (Bool
has_str_info, String -> SDoc
text String
"Str=" SDoc -> SDoc -> SDoc
<> StrictSig -> SDoc
pprStrictness StrictSig
str_info)
, (Bool
has_cpr_info, String -> SDoc
text String
"Cpr=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr CprSig
cpr_info)
, (Bool
has_unf, String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Unfolding
unf_info)
, (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules), String -> SDoc
text String
"RULES:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> SDoc
pprRule [CoreRule]
rules))
]
where
pp_scope :: SDoc
pp_scope | Id -> Bool
isGlobalId Id
id = String -> SDoc
text String
"GblId"
| Id -> Bool
isExportedId Id
id = String -> SDoc
text String
"LclIdX"
| Bool
otherwise = String -> SDoc
text String
"LclId"
arity :: ArityInfo
arity = IdInfo -> ArityInfo
arityInfo IdInfo
info
has_arity :: Bool
has_arity = ArityInfo
arity forall a. Eq a => a -> a -> Bool
/= ArityInfo
0
called_arity :: ArityInfo
called_arity = IdInfo -> ArityInfo
callArityInfo IdInfo
info
has_called_arity :: Bool
has_called_arity = ArityInfo
called_arity forall a. Eq a => a -> a -> Bool
/= ArityInfo
0
caf_info :: CafInfo
caf_info = IdInfo -> CafInfo
cafInfo IdInfo
info
has_caf_info :: Bool
has_caf_info = Bool -> Bool
not (CafInfo -> Bool
mayHaveCafRefs CafInfo
caf_info)
str_info :: StrictSig
str_info = IdInfo -> StrictSig
strictnessInfo IdInfo
info
has_str_info :: Bool
has_str_info = Bool -> Bool
not (StrictSig -> Bool
isTopSig StrictSig
str_info)
cpr_info :: CprSig
cpr_info = IdInfo -> CprSig
cprInfo IdInfo
info
has_cpr_info :: Bool
has_cpr_info = CprSig
cpr_info forall a. Eq a => a -> a -> Bool
/= CprSig
topCprSig
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo IdInfo
info
has_unf :: Bool
has_unf = Unfolding -> Bool
hasSomeUnfolding Unfolding
unf_info
rules :: [CoreRule]
rules = RuleInfo -> [CoreRule]
ruleInfoRules (IdInfo -> RuleInfo
ruleInfo IdInfo
info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes :: [(Bool, SDoc)] -> SDoc
showAttributes [(Bool, SDoc)]
stuff
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
docs = SDoc
empty
| Bool
otherwise = SDoc -> SDoc
brackets ([SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
docs))
where
docs :: [SDoc]
docs = [SDoc
d | (Bool
True,SDoc
d) <- [(Bool, SDoc)]
stuff]
instance Outputable UnfoldingGuidance where
ppr :: UnfoldingGuidance -> SDoc
ppr UnfoldingGuidance
UnfNever = String -> SDoc
text String
"NEVER"
ppr (UnfWhen { ug_arity :: UnfoldingGuidance -> ArityInfo
ug_arity = ArityInfo
arity, ug_unsat_ok :: UnfoldingGuidance -> Bool
ug_unsat_ok = Bool
unsat_ok, ug_boring_ok :: UnfoldingGuidance -> Bool
ug_boring_ok = Bool
boring_ok })
= String -> SDoc
text String
"ALWAYS_IF" SDoc -> SDoc -> SDoc
<>
SDoc -> SDoc
parens (String -> SDoc
text String
"arity=" SDoc -> SDoc -> SDoc
<> ArityInfo -> SDoc
int ArityInfo
arity SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"unsat_ok=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
unsat_ok SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"boring_ok=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
boring_ok)
ppr (UnfIfGoodArgs { ug_args :: UnfoldingGuidance -> [ArityInfo]
ug_args = [ArityInfo]
cs, ug_size :: UnfoldingGuidance -> ArityInfo
ug_size = ArityInfo
size, ug_res :: UnfoldingGuidance -> ArityInfo
ug_res = ArityInfo
discount })
= [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"IF_ARGS",
SDoc -> SDoc
brackets ([SDoc] -> SDoc
hsep (forall a b. (a -> b) -> [a] -> [b]
map ArityInfo -> SDoc
int [ArityInfo]
cs)),
ArityInfo -> SDoc
int ArityInfo
size,
ArityInfo -> SDoc
int ArityInfo
discount ]
instance Outputable UnfoldingSource where
ppr :: UnfoldingSource -> SDoc
ppr UnfoldingSource
InlineCompulsory = String -> SDoc
text String
"Compulsory"
ppr UnfoldingSource
InlineStable = String -> SDoc
text String
"InlineStable"
ppr UnfoldingSource
InlineRhs = String -> SDoc
text String
"<vanilla>"
instance Outputable Unfolding where
ppr :: Unfolding -> SDoc
ppr Unfolding
NoUnfolding = String -> SDoc
text String
"No unfolding"
ppr Unfolding
BootUnfolding = String -> SDoc
text String
"No unfolding (from boot)"
ppr (OtherCon [AltCon]
cs) = String -> SDoc
text String
"OtherCon" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [AltCon]
cs
ppr (DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
= SDoc -> ArityInfo -> SDoc -> SDoc
hang (String -> SDoc
text String
"DFun:" SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit String
"\\")
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [Id]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow)
ArityInfo
2 (forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args))
ppr (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src
, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl=CoreExpr
rhs, uf_is_top :: Unfolding -> Bool
uf_is_top=Bool
top, uf_is_value :: Unfolding -> Bool
uf_is_value=Bool
hnf
, uf_is_conlike :: Unfolding -> Bool
uf_is_conlike=Bool
conlike, uf_is_work_free :: Unfolding -> Bool
uf_is_work_free=Bool
wf
, uf_expandable :: Unfolding -> Bool
uf_expandable=Bool
exp, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance=UnfoldingGuidance
g })
= String -> SDoc
text String
"Unf" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (SDoc
pp_info SDoc -> SDoc -> SDoc
$$ SDoc
pp_rhs)
where
pp_info :: SDoc
pp_info = [SDoc] -> SDoc
fsep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ String -> SDoc
text String
"Src=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr UnfoldingSource
src
, String -> SDoc
text String
"TopLvl=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
top
, String -> SDoc
text String
"Value=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
hnf
, String -> SDoc
text String
"ConLike=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
conlike
, String -> SDoc
text String
"WorkFree=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
wf
, String -> SDoc
text String
"Expandable=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Bool
exp
, String -> SDoc
text String
"Guidance=" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr UnfoldingGuidance
g ]
pp_tmpl :: SDoc
pp_tmpl = (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressUnfoldings
(String -> SDoc
text String
"Tmpl=" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
rhs)
pp_rhs :: SDoc
pp_rhs | UnfoldingSource -> Bool
isStableSource UnfoldingSource
src = SDoc
pp_tmpl
| Bool
otherwise = SDoc
empty
instance Outputable CoreRule where
ppr :: CoreRule -> SDoc
ppr = CoreRule -> SDoc
pprRule
pprRules :: [CoreRule] -> SDoc
pprRules :: [CoreRule] -> SDoc
pprRules [CoreRule]
rules = [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map CoreRule -> SDoc
pprRule [CoreRule]
rules)
pprRule :: CoreRule -> SDoc
pprRule :: CoreRule -> SDoc
pprRule (BuiltinRule { ru_fn :: CoreRule -> Name
ru_fn = Name
fn, ru_name :: CoreRule -> RuleName
ru_name = RuleName
name})
= String -> SDoc
text String
"Built in rule for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
fn SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (RuleName -> SDoc
ftext RuleName
name)
pprRule (Rule { ru_name :: CoreRule -> RuleName
ru_name = RuleName
name, ru_act :: CoreRule -> Activation
ru_act = Activation
act, ru_fn :: CoreRule -> Name
ru_fn = Name
fn,
ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
tpl_vars, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
tpl_args,
ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
= SDoc -> ArityInfo -> SDoc -> SDoc
hang (SDoc -> SDoc
doubleQuotes (RuleName -> SDoc
ftext RuleName
name) SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Activation
act)
ArityInfo
4 ([SDoc] -> SDoc
sep [String -> SDoc
text String
"forall" SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
pprCoreBinders [Id]
tpl_vars SDoc -> SDoc -> SDoc
<> SDoc
dot,
ArityInfo -> SDoc -> SDoc
nest ArityInfo
2 (forall a. Outputable a => a -> SDoc
ppr Name
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall b. OutputableBndr b => Expr b -> SDoc
pprArg [CoreExpr]
tpl_args)),
ArityInfo -> SDoc -> SDoc
nest ArityInfo
2 (String -> SDoc
text String
"=" SDoc -> SDoc -> SDoc
<+> forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
rhs)
])
instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where
ppr :: GenTickish pass -> SDoc
ppr (HpcTick Module
modl ArityInfo
ix) =
[SDoc] -> SDoc
hcat [String -> SDoc
text String
"hpc<",
forall a. Outputable a => a -> SDoc
ppr Module
modl, SDoc
comma,
forall a. Outputable a => a -> SDoc
ppr ArityInfo
ix,
String -> SDoc
text String
">"]
ppr (Breakpoint XBreakpoint pass
_ext ArityInfo
ix [XTickishId pass]
vars) =
[SDoc] -> SDoc
hcat [String -> SDoc
text String
"break<",
forall a. Outputable a => a -> SDoc
ppr ArityInfo
ix,
String -> SDoc
text String
">",
SDoc -> SDoc
parens ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [XTickishId pass]
vars)))]
ppr (ProfNote { profNoteCC :: forall (pass :: TickishPass). GenTickish pass -> CostCentre
profNoteCC = CostCentre
cc,
profNoteCount :: forall (pass :: TickishPass). GenTickish pass -> Bool
profNoteCount = Bool
tick,
profNoteScope :: forall (pass :: TickishPass). GenTickish pass -> Bool
profNoteScope = Bool
scope }) =
case (Bool
tick,Bool
scope) of
(Bool
True,Bool
True) -> [SDoc] -> SDoc
hcat [String -> SDoc
text String
"scctick<", forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char Char
'>']
(Bool
True,Bool
False) -> [SDoc] -> SDoc
hcat [String -> SDoc
text String
"tick<", forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char Char
'>']
(Bool, Bool)
_ -> [SDoc] -> SDoc
hcat [String -> SDoc
text String
"scc<", forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char Char
'>']
ppr (SourceNote RealSrcSpan
span String
_) =
[SDoc] -> SDoc
hcat [ String -> SDoc
text String
"src<", Bool -> RealSrcSpan -> SDoc
pprUserRealSpan Bool
True RealSrcSpan
span, Char -> SDoc
char Char
'>']