{-# 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,
        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.Data.Maybe
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 :: forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings = Annotation b -> [Bind b] -> SDoc
forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds Annotation b
forall b. Expr b -> SDoc
noAnn
pprCoreBinding :: forall b. OutputableBndr b => Bind b -> SDoc
pprCoreBinding  = Annotation b -> Bind b -> SDoc
forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind Annotation b
forall b. Expr b -> SDoc
noAnn

pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingWithSize  :: CoreBind  -> SDoc

pprCoreBindingsWithSize :: [CoreBind] -> SDoc
pprCoreBindingsWithSize = Annotation Id -> [CoreBind] -> SDoc
forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds Annotation Id
sizeAnn
pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingWithSize = Annotation Id -> CoreBind -> SDoc
forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind Annotation Id
sizeAnn

instance OutputableBndr b => Outputable (Bind b) where
    ppr :: Bind b -> SDoc
ppr Bind b
bind = Annotation b -> Bind b -> SDoc
forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
ppr_bind Annotation b
forall b. Expr b -> SDoc
noAnn Bind b
bind

instance OutputableBndr b => Outputable (Expr b) where
    ppr :: Expr b -> SDoc
ppr Expr b
expr = Expr b -> SDoc
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 = Alt b -> SDoc
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 :: Annotation Id
sizeAnn CoreExpr
e = String -> SDoc
text String
"-- RHS size:" SDoc -> SDoc -> SDoc
<+> CoreStats -> 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 ((Bind a -> SDoc) -> [Bind a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Annotation a -> Bind a -> SDoc
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)
 = Annotation a -> (a, Expr a) -> SDoc
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 {",
          Annotation a -> (a, Expr a) -> SDoc
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
$$ Annotation a -> (a, Expr a) -> 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) = Annotation b -> (b, Expr b) -> SDoc
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 (((b, Expr b) -> SDoc) -> [(b, Expr b)] -> [SDoc]
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 = Annotation b -> (b, Expr b) -> SDoc
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
             (BindingSite -> b -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind b
val_bdr)
         , SDoc
pp_bind
         ]
  where
    pp_val_bdr :: SDoc
pp_val_bdr = b -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc b
val_bdr

    pp_bind :: SDoc
pp_bind = case b -> Maybe ArityInfo
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
<+> Annotation b
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 [b] -> ArityInfo -> Bool
forall a. [a] -> ArityInfo -> Bool
`lengthAtLeast` ArityInfo
join_arity
      = SDoc -> ArityInfo -> SDoc -> SDoc
hang (SDoc
pp_val_bdr SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((b -> SDoc) -> [b] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> b -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [b]
lhs_bndrs))
           ArityInfo
2 (SDoc
equals SDoc -> SDoc -> SDoc
<+> Annotation b
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) = Expr b -> ([b], Expr b)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr b
expr
        lhs_bndrs :: [b]
lhs_bndrs = ArityInfo -> [b] -> [b]
forall a. ArityInfo -> [a] -> [a]
take ArityInfo
join_arity [b]
bndrs
        rhs :: Expr b
rhs       = [b] -> Expr b -> Expr b
forall b. [b] -> Expr b -> Expr b
mkLams (ArityInfo -> [b] -> [b]
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 = (SDoc -> SDoc) -> Expr b -> SDoc
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 = (SDoc -> SDoc) -> Expr b -> SDoc
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 = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressCoercions ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
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)) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> SDoc
co_type
              Bool
False -> SDoc -> SDoc
parens (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep [Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co, SDoc
dcolon SDoc -> SDoc -> SDoc
<+> SDoc
co_type]
    where
      co_type :: SDoc
co_type = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressCoercionTypes ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
          Bool
True -> String -> SDoc
text String
"..."
          Bool
False -> Type -> 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 = Id -> SDoc
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
<+> Type -> 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
<+> Coercion -> 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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep [Expr b -> SDoc
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) = Expr b -> ([b], Expr b)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr b
expr
    in
    SDoc -> SDoc
add_par (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    SDoc -> ArityInfo -> SDoc -> SDoc
hang (String -> SDoc
text String
"\\" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((b -> SDoc) -> [b] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> b -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [b]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow)
         ArityInfo
2 (Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
body)

ppr_expr SDoc -> SDoc
add_par expr :: Expr b
expr@(App {})
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeApplications ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
supp_ty_app ->
    case Expr b -> (Expr b, [Expr b])
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 ((Expr b -> SDoc) -> [Expr b] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprArg [Expr b]
args)
        val_args :: [Expr b]
val_args    = (Expr b -> Bool) -> [Expr b] -> [Expr b]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Expr b -> Bool
forall b. Expr b -> Bool
isTypeArg [Expr b]
args   -- Drop the type arguments for tuples
        pp_tup_args :: SDoc
pp_tup_args = (Expr b -> SDoc) -> [Expr b] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Expr b -> SDoc
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
          | [Expr b] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr b]
args' = SDoc -> SDoc
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 [Expr b] -> ArityInfo -> Bool
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 (Expr b -> SDoc
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])
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintCaseAsLet ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True -> SDoc -> SDoc
add_par (SDoc -> SDoc) -> SDoc -> SDoc
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
<+> AltCon -> [b] -> 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
<+> (SDoc -> SDoc) -> Expr b -> SDoc
forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
forall a. a -> a
id Expr b
expr
                           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"} in" ]
                   , Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs
                   ]
      Bool
False -> SDoc -> SDoc
add_par (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                [SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [ String -> SDoc
text String
"case" SDoc -> SDoc -> SDoc
<+> Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr
                              , SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"return" SDoc -> SDoc -> SDoc
<+> Type -> 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
<+> AltCon -> [b] -> SDoc
forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat AltCon
con [b]
args SDoc -> SDoc -> SDoc
<+> SDoc
arrow
                         ]
                     , Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs
                     , Char -> SDoc
char Char
'}'
                     ]
  where
    ppr_bndr :: b -> SDoc
ppr_bndr = BindingSite -> b -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [[SDoc] -> SDoc
sep [String -> SDoc
text String
"case"
                SDoc -> SDoc -> SDoc
<+> Expr b -> 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
<+> Type -> 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 ((Alt b -> SDoc) -> [Alt b] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Alt b -> SDoc
forall b. OutputableBndr b => Alt b -> SDoc
pprCoreAlt [Alt b]
alts))),
         Char -> SDoc
char Char
'}'
    ]
  where
    ppr_bndr :: b -> SDoc
ppr_bndr = BindingSite -> b -> SDoc
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [SDoc -> ArityInfo -> SDoc -> SDoc
hang (Bind b -> SDoc
forall b. OutputableBndr b => Bind b -> SDoc
keyword Bind b
bind SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'{') ArityInfo
2 ((Expr b -> SDoc) -> Bind b -> SDoc
forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
ppr_bind Expr b -> SDoc
forall b. Expr b -> SDoc
noAnn Bind b
bind SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"} in"),
         Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr]
  where
    keyword :: Bind a -> SDoc
keyword (NonRec a
b Expr a
_)
     | Maybe ArityInfo -> Bool
forall a. Maybe a -> Bool
isJust (a -> Maybe ArityInfo
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
     , Maybe ArityInfo -> Bool
forall a. Maybe a -> Bool
isJust (a -> Maybe ArityInfo
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)
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTicks ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
      Bool
True  -> (SDoc -> SDoc) -> Expr b -> SDoc
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 [CoreTickish -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreTickish
tickish, Expr b -> SDoc
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 (AltCon -> [a] -> SDoc
forall a. OutputableBndr a => AltCon -> [a] -> SDoc
ppr_case_pat AltCon
con [a]
args SDoc -> SDoc -> SDoc
<+> SDoc
arrow) ArityInfo
2 (Expr a -> SDoc
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 ((a -> SDoc) -> [a] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas a -> SDoc
ppr_bndr [a]
args)
  where
    ppr_bndr :: a -> SDoc
ppr_bndr = BindingSite -> a -> SDoc
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
  = AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
fsep ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
ppr_bndr [a]
args))
  where
    ppr_bndr :: a -> SDoc
ppr_bndr = BindingSite -> a -> SDoc
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          = Expr a -> SDoc
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  = Name -> SDoc
forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName  (Name -> SDoc) -> (Id -> Name) -> Id -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
varName
  pprPrefixOcc :: Id -> SDoc
pprPrefixOcc = Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (Name -> SDoc) -> (Id -> Name) -> Id -> SDoc
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 = TaggedBndr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b   -- Simple
  pprInfixOcc :: TaggedBndr b -> SDoc
pprInfixOcc  TaggedBndr b
b = TaggedBndr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
  pprPrefixOcc :: TaggedBndr b -> SDoc
pprPrefixOcc TaggedBndr b
b = TaggedBndr b -> SDoc
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

pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc :: forall a. OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc LexicalFixity
Infix  = a -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprInfixOcc
pprOcc LexicalFixity
Prefix = a -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc

pprOccWithTick :: OutputableBndr a => LexicalFixity -> PromotionFlag -> a -> SDoc
pprOccWithTick :: forall a.
OutputableBndr a =>
LexicalFixity -> PromotionFlag -> a -> SDoc
pprOccWithTick LexicalFixity
fixity PromotionFlag
prom a
op
  | PromotionFlag -> Bool
isPromoted PromotionFlag
prom
  = SDoc -> SDoc
quote (LexicalFixity -> a -> SDoc
forall a. OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc LexicalFixity
fixity a
op)
  | Bool
otherwise
  = LexicalFixity -> a -> SDoc
forall a. OutputableBndr a => LexicalFixity -> a -> SDoc
pprOcc LexicalFixity
fixity a
op

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 ((() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
binder)

-- Lambda bound type variables are preceded by "@"
pprCoreBinder BindingSite
bind_site Id
bndr
  = (Bool -> SDoc) -> SDoc
getPprDebug ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
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 ((Id -> SDoc) -> [Id] -> [SDoc]
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
<> Id -> 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
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeSignatures ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
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 ((() :: Constraint) => Id -> IdInfo
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
realUnfoldingInfo ((() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
var)
    pp_unf :: SDoc
pp_unf | Unfolding -> Bool
hasSomeUnfolding Unfolding
unf_info = String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> Unfolding -> 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
  = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocSuppressTypeSignatures ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
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 = Id -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc Id
id SDoc -> SDoc -> SDoc
<+> IdInfo -> SDoc
pprIdBndrInfo ((() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
id)

pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo IdInfo
info
  = (SDocContext -> Bool) -> SDoc -> SDoc
ppUnlessOption SDocContext -> Bool
sdocSuppressIdInfo
      (IdInfo
info IdInfo -> SDoc -> SDoc
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 (Bool -> Bool) -> Bool -> Bool
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
<> OccInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccInfo
occ_info)
          , (Bool
has_dmd,  String -> SDoc
text String
"Dmd=" SDoc -> SDoc -> SDoc
<> Demand -> SDoc
forall a. Outputable a => a -> SDoc
ppr Demand
dmd_info)
          , (Bool
has_lbv , String -> SDoc
text String
"OS=" SDoc -> SDoc -> SDoc
<> OneShotInfo -> 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
<> OccInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccInfo
occ_info)
    , (Bool
has_dmd,          String -> SDoc
text String
"Dmd=" SDoc -> SDoc -> SDoc
<> Demand -> SDoc
forall a. Outputable a => a -> SDoc
ppr Demand
dmd_info)
    , (Bool
has_lbv ,         String -> SDoc
text String
"OS=" SDoc -> SDoc -> SDoc
<> OneShotInfo -> 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
<> CafInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CafInfo
caf_info)
    , (Bool
has_str_info,     String -> SDoc
text String
"Str=" SDoc -> SDoc -> SDoc
<> DmdSig -> SDoc
pprStrictness DmdSig
str_info)
    , (Bool
has_unf,          String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> Unfolding -> 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 ((CoreRule -> SDoc) -> [CoreRule] -> [SDoc]
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 (Bool -> Bool) -> Bool -> Bool
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 ArityInfo -> ArityInfo -> Bool
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 ArityInfo -> ArityInfo -> Bool
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 :: DmdSig
str_info = IdInfo -> DmdSig
dmdSigInfo IdInfo
info
      has_str_info :: Bool
has_str_info = Bool -> Bool
not (DmdSig -> Bool
isNopSig DmdSig
str_info)

      unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
realUnfoldingInfo 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 ([CoreRule] -> Bool
forall a. [a] -> Bool
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 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [(Bool, SDoc)] -> SDoc
showAttributes
    [ (Bool
True, SDoc
pp_scope SDoc -> SDoc -> SDoc
<> IdDetails -> 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
<> CafInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CafInfo
caf_info)
    , (Bool
has_str_info,     String -> SDoc
text String
"Str=" SDoc -> SDoc -> SDoc
<> DmdSig -> SDoc
pprStrictness DmdSig
str_info)
    , (Bool
has_cpr_info,     String -> SDoc
text String
"Cpr=" SDoc -> SDoc -> SDoc
<> CprSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr CprSig
cpr_info)
    , (Bool
has_unf,          String -> SDoc
text String
"Unf=" SDoc -> SDoc -> SDoc
<> Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
unf_info)
    , (Bool -> Bool
not ([CoreRule] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules), String -> SDoc
text String
"RULES:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((CoreRule -> SDoc) -> [CoreRule] -> [SDoc]
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 ArityInfo -> ArityInfo -> Bool
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 ArityInfo -> ArityInfo -> Bool
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 :: DmdSig
str_info = IdInfo -> DmdSig
dmdSigInfo IdInfo
info
    has_str_info :: Bool
has_str_info = Bool -> Bool
not (DmdSig -> Bool
isNopSig DmdSig
str_info)

    cpr_info :: CprSig
cpr_info = IdInfo -> CprSig
cprSigInfo IdInfo
info
    has_cpr_info :: Bool
has_cpr_info = CprSig
cpr_info CprSig -> CprSig -> Bool
forall a. Eq a => a -> a -> Bool
/= CprSig
topCprSig

    unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
realUnfoldingInfo 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
  | [SDoc] -> Bool
forall a. [a] -> Bool
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
<> Bool -> 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
<> Bool -> 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 ((ArityInfo -> SDoc) -> [ArityInfo] -> [SDoc]
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
<+> [AltCon] -> 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
<+> Char -> SDoc
char Char
'\\'
                SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [Id]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow)
            ArityInfo
2 (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (Annotation Id -> [CoreExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Annotation Id
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_cache :: Unfolding -> UnfoldingCache
uf_cache=UnfoldingCache
cache, 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 ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
                [ String -> SDoc
text String
"Src="        SDoc -> SDoc -> SDoc
<> UnfoldingSource -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnfoldingSource
src
                , String -> SDoc
text String
"TopLvl="     SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
top
                , UnfoldingCache -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnfoldingCache
cache
                , String -> SDoc
text String
"Guidance="   SDoc -> SDoc -> SDoc
<> UnfoldingGuidance -> 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
<+> Annotation Id
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!

instance Outputable UnfoldingCache where
    ppr :: UnfoldingCache -> SDoc
ppr (UnfoldingCache { uf_is_value :: UnfoldingCache -> Bool
uf_is_value = Bool
hnf, uf_is_conlike :: UnfoldingCache -> Bool
uf_is_conlike = Bool
conlike
                        , uf_is_work_free :: UnfoldingCache -> Bool
uf_is_work_free = Bool
wf, uf_expandable :: UnfoldingCache -> Bool
uf_expandable = Bool
exp })
        = [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
          [ String -> SDoc
text String
"Value="      SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
hnf
          , String -> SDoc
text String
"ConLike="    SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
conlike
          , String -> SDoc
text String
"WorkFree="   SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
wf
          , String -> SDoc
text String
"Expandable=" SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
exp ]

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

instance Outputable CoreRule where
   ppr :: CoreRule -> SDoc
ppr = CoreRule -> SDoc
pprRule

pprRules :: [CoreRule] -> SDoc
pprRules :: [CoreRule] -> SDoc
pprRules [CoreRule]
rules = [SDoc] -> SDoc
vcat ((CoreRule -> SDoc) -> [CoreRule] -> [SDoc]
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
<+> Name -> 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
<+> Activation -> 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 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (Annotation Id -> [CoreExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Annotation Id
forall b. OutputableBndr b => Expr b -> SDoc
pprArg [CoreExpr]
tpl_args)),
               ArityInfo -> SDoc -> SDoc
nest ArityInfo
2 (String -> SDoc
text String
"=" SDoc -> SDoc -> SDoc
<+> Annotation Id
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<",
            Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
modl, SDoc
comma,
            ArityInfo -> SDoc
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<",
            ArityInfo -> SDoc
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 ((XTickishId pass -> SDoc) -> [XTickishId pass] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map XTickishId pass -> SDoc
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<", CostCentre -> SDoc
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<",    CostCentre -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char Char
'>']
         (Bool, Bool)
_            -> [SDoc] -> SDoc
hcat [String -> SDoc
text String
"scc<",     CostCentre -> SDoc
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
'>']