{-# 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,
        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

{-
************************************************************************
*                                                                      *
\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 :: 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

{-
************************************************************************
*                                                                      *
\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 :: 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)

-- | No annotation
noAnn :: Expr b -> SDoc
noAnn :: forall b. Expr b -> SDoc
noAnn Expr b
_ = SDoc
empty

pprTopBinds :: OutputableBndr a
            => Annotation a -- ^ generate an annotation to place before the
                            -- binding
            -> [Bind a]     -- ^ bindings to show
            -> SDoc         -- ^ the pretty result
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)

      -- 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 :: 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 -- 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
      = 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
-- Print a coercion optionally; i.e. honouring -dsuppress-coercions
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  -- 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 :: 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)       -- Weird
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   -- Drop the type arguments for tuples
        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
                        -- Notice that we print the *worker*
                        -- for tuples in paren'd format.
                   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
$  -- See Note [Print case as let]
               [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


-- 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 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


-- | Pretty print the argument in a function application.
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

{-
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 :: 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   -- Simple
  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)

-- Lambda bound type variables are preceded by "@"
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
-- Print as lambda-binders, i.e. with their type
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    -- NB: don't print kind
  | Bool
otherwise      = Id -> SDoc
pprIdBndr Id
binder

pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
-- For lambda and case binders, show the unfolding info (usually none)
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            -- Show case-bound wild binders only if debug is on
      , BindingSite
CaseBind <- BindingSite
bind_site
      , Id -> Bool
isDeadBinder Id
var        -> SDoc
empty

      | Bool -> Bool
not Bool
debug_on            -- Even dead binders can be one-shot
      , 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            -- No parens, no kind info
      , 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
-- Print binder with a type or kind signature (not paren'd)
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
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr :: Id -> SDoc
pprKindedTyVarBndr Id
tyvar
  = String -> SDoc
text String
"@" SDoc -> SDoc -> SDoc
<> Id -> SDoc
pprTyVar Id
tyvar

-- pprIdBndr does *not* print the type
-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
pprIdBndr :: Id -> 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) -- The seq is useful for poking on black holes
  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)

{-
-----------------------------------------------------
--      IdDetails and IdInfo
-----------------------------------------------------
-}

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))
    ]   -- Inline pragma, occ, demand, one-shot info
        -- printed out with all binders (when debug is on);
        -- see GHC.Core.Ppr.pprIdBndr
  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]

{-
-----------------------------------------------------
--      Unfolding and UnfoldingGuidance
-----------------------------------------------------
-}

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
            -- Don't print the RHS or we get a quadratic
            -- blowup in the size of the printout!

{-
-----------------------------------------------------
--      Rules
-----------------------------------------------------
-}

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)
            ])

{-
-----------------------------------------------------
--      Tickish
-----------------------------------------------------
-}

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
'>']