{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1996-1998


Printing of Core syntax
-}

{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module PprCore (
        pprCoreExpr, pprParendExpr,
        pprCoreBinding, pprCoreBindings, pprCoreAlt,
        pprCoreBindingWithSize, pprCoreBindingsWithSize,
        pprRules, pprOptCo
    ) where

import GhcPrelude

import CoreSyn
import CoreStats (exprStats)
import Literal( pprLiteral )
import Name( pprInfixName, pprPrefixName )
import Var
import Id
import IdInfo
import Demand
import DataCon
import TyCon
import Type
import Coercion
import DynFlags
import BasicTypes
import Maybes
import Util
import Outputable
import FastString
import SrcLoc      ( pprUserRealSpan )

{-
************************************************************************
*                                                                      *
\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 :: [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 :: 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 CoreBndr -> [CoreBind] -> SDoc
forall a. OutputableBndr a => Annotation a -> [Bind a] -> SDoc
pprTopBinds Annotation CoreBndr
sizeAnn
pprCoreBindingWithSize :: CoreBind -> SDoc
pprCoreBindingWithSize = Annotation CoreBndr -> CoreBind -> SDoc
forall a. OutputableBndr a => Annotation a -> Bind a -> SDoc
pprTopBind Annotation CoreBndr
sizeAnn

instance OutputableBndr b => Outputable (Bind b) where
    ppr :: Bind b -> SDoc
ppr bind :: 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 :: Expr b
expr = Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr 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 CoreBndr
sizeAnn e :: CoreExpr
e = String -> SDoc
text "-- 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 :: Expr b -> SDoc
noAnn _ = 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 :: Annotation a -> [Bind a] -> SDoc
pprTopBinds ann :: Annotation a
ann binds :: [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 :: Annotation a -> Bind a -> SDoc
pprTopBind ann :: Annotation a
ann (NonRec binder :: a
binder expr :: 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 _ (Rec [])
  = String -> SDoc
text "Rec { }"
pprTopBind ann :: Annotation a
ann (Rec (b :: (a, Expr a)
b:bs :: [(a, Expr a)]
bs))
  = [SDoc] -> SDoc
vcat [String -> SDoc
text "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 "end Rec }",
          SDoc
blankLine]

ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc

ppr_bind :: Annotation b -> Bind b -> SDoc
ppr_bind ann :: Annotation b
ann (NonRec val_bdr :: b
val_bdr expr :: 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 ann :: Annotation b
ann (Rec binds :: [(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 bind :: (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 :: Annotation b -> (b, Expr b) -> SDoc
ppr_binding ann :: Annotation b
ann (val_bdr :: b
val_bdr, expr :: Expr b
expr)
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
      [SDoc] -> SDoc
vcat [ Annotation b
ann Expr b
expr
           , if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTypeSignatures DynFlags
dflags
               then SDoc
empty
               else BindingSite -> b -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LetBind b
val_bdr
           , SDoc
pp_bind
           ]
  where
    pp_bind :: SDoc
pp_bind = case b -> Maybe Int
forall a. OutputableBndr a => a -> Maybe Int
bndrIsJoin_maybe b
val_bdr of
                Nothing -> SDoc
pp_normal_bind
                Just ar :: Int
ar -> Int -> SDoc
pp_join_bind Int
ar

    pp_normal_bind :: SDoc
pp_normal_bind = SDoc -> Int -> SDoc -> SDoc
hang (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
val_bdr) 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 :: Int -> SDoc
pp_join_bind join_arity :: Int
join_arity
      | [b]
bndrs [b] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` Int
join_arity
      = SDoc -> Int -> SDoc -> SDoc
hang (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
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))
           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
        (bndrs :: [b]
bndrs, body :: Expr b
body) = Expr b -> ([b], Expr b)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr b
expr
        lhs_bndrs :: [b]
lhs_bndrs = Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
take Int
join_arity [b]
bndrs
        rhs :: Expr b
rhs       = [b] -> Expr b -> Expr b
forall b. [b] -> Expr b -> Expr b
mkLams (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
join_arity [b]
bndrs) Expr b
body

pprParendExpr :: Expr b -> SDoc
pprParendExpr expr :: 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 :: Expr b -> SDoc
pprCoreExpr   expr :: 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 pp :: SDoc
pp = SDoc
pp

pprOptCo :: Coercion -> SDoc
-- Print a coercion optionally; i.e. honouring -dsuppress-coercions
pprOptCo :: Coercion -> SDoc
pprOptCo co :: Coercion
co = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
              if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoercions DynFlags
dflags
              then SDoc -> SDoc
angleBrackets (String -> SDoc
text "Co:" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int (Coercion -> Int
coercionSize Coercion
co))
              else SDoc -> SDoc
parens ([SDoc] -> SDoc
sep [Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co, SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Coercion -> Type
coercionType Coercion
co)])

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 :: (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr add_par :: SDoc -> SDoc
add_par (Var name :: CoreBndr
name)
 | CoreBndr -> Bool
isJoinId CoreBndr
name               = SDoc -> SDoc
add_par ((String -> SDoc
text "jump") SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
name)
 | Bool
otherwise                   = CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
name
ppr_expr add_par :: SDoc -> SDoc
add_par (Type ty :: Type
ty)     = SDoc -> SDoc
add_par (String -> SDoc
text "TYPE:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)       -- Weird
ppr_expr add_par :: SDoc -> SDoc
add_par (Coercion co :: Coercion
co) = SDoc -> SDoc
add_par (String -> SDoc
text "CO:" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr Coercion
co)
ppr_expr add_par :: SDoc -> SDoc
add_par (Lit lit :: Literal
lit)     = (SDoc -> SDoc) -> Literal -> SDoc
pprLiteral SDoc -> SDoc
add_par Literal
lit

ppr_expr add_par :: SDoc -> SDoc
add_par (Cast expr :: Expr b
expr co :: 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 "`cast`" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
pprOptCo Coercion
co]

ppr_expr add_par :: SDoc -> SDoc
add_par expr :: Expr b
expr@(Lam _ _)
  = let
        (bndrs :: [b]
bndrs, body :: 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 -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "\\" 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)
         2 (Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
body)

ppr_expr add_par :: SDoc -> SDoc
add_par expr :: Expr b
expr@(App {})
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    case Expr b -> (Expr b, [Expr b])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr b
expr of { (fun :: Expr b
fun, args :: [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'
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTypeApplications DynFlags
dflags = [Expr b]
val_args
          | Bool
otherwise = [Expr b]
args
        parens :: SDoc -> SDoc
parens
          | [Expr b] -> 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 f :: CoreBndr
f -> case CoreBndr -> Maybe DataCon
isDataConWorkId_maybe CoreBndr
f of
                        -- Notice that we print the *worker*
                        -- for tuples in paren'd format.
                   Just dc :: DataCon
dc | Bool
saturated
                           , Just sort :: 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] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` CoreBndr -> Int
idArity CoreBndr
f

                   _ -> SDoc -> SDoc
parens (SDoc -> Int -> SDoc -> SDoc
hang SDoc
fun_doc 2 SDoc
pp_args)
                   where
                     fun_doc :: SDoc
fun_doc | CoreBndr -> Bool
isJoinId CoreBndr
f = String -> SDoc
text "jump" SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
f
                             | Bool
otherwise  = CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
f

        _ -> SDoc -> SDoc
parens (SDoc -> Int -> SDoc -> SDoc
hang (Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr Expr b
fun) 2 SDoc
pp_args)
    }

ppr_expr add_par :: SDoc -> SDoc
add_par (Case expr :: Expr b
expr var :: b
var ty :: Type
ty [(con :: AltCon
con,args :: [b]
args,rhs :: Expr b
rhs)])
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PprCaseAsLet DynFlags
dflags
    then 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 "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 "~"
                     SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var
                   , String -> SDoc
text "<-" 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 "} in" ]
             , Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
rhs
             ]
    else 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 "case" SDoc -> SDoc -> SDoc
<+> Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr
                       , SDoc -> SDoc
whenPprDebug (String -> SDoc
text "return" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
                       , String -> SDoc
text "of" SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var
                       ]
                  , Char -> SDoc
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 '}'
              ]
  where
    ppr_bndr :: b -> SDoc
ppr_bndr = BindingSite -> b -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
CaseBind

ppr_expr add_par :: SDoc -> SDoc
add_par (Case expr :: Expr b
expr var :: b
var ty :: Type
ty alts :: [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 "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 "return" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty),
              String -> SDoc
text "of" SDoc -> SDoc -> SDoc
<+> b -> SDoc
ppr_bndr b
var SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char '{'],
         Int -> SDoc -> SDoc
nest 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 a. OutputableBndr a => (AltCon, [a], Expr a) -> SDoc
pprCoreAlt [Alt b]
alts))),
         Char -> SDoc
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 add_par :: SDoc -> SDoc
add_par (Let bind :: Bind b
bind expr :: Expr b
expr)
  = SDoc -> SDoc
add_par (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
sep [SDoc -> Int -> SDoc -> SDoc
hang (Bind b -> SDoc
forall b. OutputableBndr b => Bind b -> SDoc
keyword Bind b
bind SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char '{') 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 "} in"),
         Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr]
  where
    keyword :: Bind a -> SDoc
keyword (NonRec b :: a
b _)
     | Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (a -> Maybe Int
forall a. OutputableBndr a => a -> Maybe Int
bndrIsJoin_maybe a
b) = String -> SDoc
text "join"
     | Bool
otherwise                   = String -> SDoc
text "let"
    keyword (Rec pairs :: [(a, Expr a)]
pairs)
     | ((b :: a
b,_):_) <- [(a, Expr a)]
pairs
     , Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (a -> Maybe Int
forall a. OutputableBndr a => a -> Maybe Int
bndrIsJoin_maybe a
b) = String -> SDoc
text "joinrec"
     | Bool
otherwise                   = String -> SDoc
text "letrec"

ppr_expr add_par :: SDoc -> SDoc
add_par (Tick tickish :: Tickish CoreBndr
tickish expr :: Expr b
expr)
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTicks DynFlags
dflags
  then (SDoc -> SDoc) -> Expr b -> SDoc
forall b. OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
ppr_expr SDoc -> SDoc
add_par Expr b
expr
  else SDoc -> SDoc
add_par ([SDoc] -> SDoc
sep [Tickish CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish CoreBndr
tickish, Expr b -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr Expr b
expr])

pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
pprCoreAlt :: (AltCon, [a], Expr a) -> SDoc
pprCoreAlt (con :: AltCon
con, args :: [a]
args, rhs :: Expr a
rhs)
  = SDoc -> Int -> 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) 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 :: AltCon -> [a] -> SDoc
ppr_case_pat (DataAlt dc :: DataCon
dc) args :: [a]
args
  | Just sort :: 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 con :: AltCon
con args :: [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 :: Expr a -> SDoc
pprArg (Type ty :: Type
ty)
 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
   if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTypeApplications DynFlags
dflags
   then SDoc
empty
   else String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
ty
pprArg (Coercion co :: Coercion
co) = String -> SDoc
text "@~" SDoc -> SDoc -> SDoc
<+> Coercion -> SDoc
pprOptCo Coercion
co
pprArg expr :: 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 -> CoreBndr -> SDoc
pprBndr = BindingSite -> CoreBndr -> SDoc
pprCoreBinder
  pprInfixOcc :: CoreBndr -> SDoc
pprInfixOcc  = Name -> SDoc
forall a. (Outputable a, NamedThing a) => a -> SDoc
pprInfixName  (Name -> SDoc) -> (CoreBndr -> Name) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName
  pprPrefixOcc :: CoreBndr -> SDoc
pprPrefixOcc = Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (Name -> SDoc) -> (CoreBndr -> Name) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
varName
  bndrIsJoin_maybe :: CoreBndr -> Maybe Int
bndrIsJoin_maybe = CoreBndr -> Maybe Int
isJoinId_maybe

instance Outputable b => OutputableBndr (TaggedBndr b) where
  pprBndr :: BindingSite -> TaggedBndr b -> SDoc
pprBndr _    b :: TaggedBndr b
b = TaggedBndr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b   -- Simple
  pprInfixOcc :: TaggedBndr b -> SDoc
pprInfixOcc  b :: TaggedBndr b
b = TaggedBndr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
  pprPrefixOcc :: TaggedBndr b -> SDoc
pprPrefixOcc b :: TaggedBndr b
b = TaggedBndr b -> SDoc
forall a. Outputable a => a -> SDoc
ppr TaggedBndr b
b
  bndrIsJoin_maybe :: TaggedBndr b -> Maybe Int
bndrIsJoin_maybe (TB b :: CoreBndr
b _) = CoreBndr -> Maybe Int
isJoinId_maybe CoreBndr
b

pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder :: BindingSite -> CoreBndr -> SDoc
pprCoreBinder LetBind binder :: CoreBndr
binder
  | CoreBndr -> Bool
isTyVar CoreBndr
binder = CoreBndr -> SDoc
pprKindedTyVarBndr CoreBndr
binder
  | Bool
otherwise      = CoreBndr -> SDoc
pprTypedLetBinder CoreBndr
binder SDoc -> SDoc -> SDoc
$$
                     CoreBndr -> IdInfo -> SDoc
ppIdInfo CoreBndr
binder (HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
binder)

-- Lambda bound type variables are preceded by "@"
pprCoreBinder bind_site :: BindingSite
bind_site bndr :: CoreBndr
bndr
  = (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \ sty :: PprStyle
sty ->
    BindingSite -> Bool -> CoreBndr -> SDoc
pprTypedLamBinder BindingSite
bind_site (PprStyle -> Bool
debugStyle PprStyle
sty) CoreBndr
bndr

pprUntypedBinder :: Var -> SDoc
pprUntypedBinder :: CoreBndr -> SDoc
pprUntypedBinder binder :: CoreBndr
binder
  | CoreBndr -> Bool
isTyVar CoreBndr
binder = String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
binder    -- NB: don't print kind
  | Bool
otherwise      = CoreBndr -> SDoc
pprIdBndr CoreBndr
binder

pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
-- For lambda and case binders, show the unfolding info (usually none)
pprTypedLamBinder :: BindingSite -> Bool -> CoreBndr -> SDoc
pprTypedLamBinder bind_site :: BindingSite
bind_site debug_on :: Bool
debug_on var :: CoreBndr
var
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    case () of
    _
      | Bool -> Bool
not Bool
debug_on            -- Show case-bound wild binders only if debug is on
      , BindingSite
CaseBind <- BindingSite
bind_site
      , CoreBndr -> Bool
isDeadBinder CoreBndr
var        -> SDoc
empty

      | Bool -> Bool
not Bool
debug_on            -- Even dead binders can be one-shot
      , CoreBndr -> Bool
isDeadBinder CoreBndr
var        -> Char -> SDoc
char '_' SDoc -> SDoc -> SDoc
<+> Bool -> SDoc -> SDoc
ppWhen (CoreBndr -> Bool
isId CoreBndr
var)
                                                (IdInfo -> SDoc
pprIdBndrInfo (HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
var))

      | Bool -> Bool
not Bool
debug_on            -- No parens, no kind info
      , BindingSite
CaseBind <- BindingSite
bind_site   -> CoreBndr -> SDoc
pprUntypedBinder CoreBndr
var

      | Bool -> Bool
not Bool
debug_on
      , BindingSite
CasePatBind <- BindingSite
bind_site    -> CoreBndr -> SDoc
pprUntypedBinder CoreBndr
var

      | DynFlags -> Bool
suppress_sigs DynFlags
dflags    -> CoreBndr -> SDoc
pprUntypedBinder CoreBndr
var

      | CoreBndr -> Bool
isTyVar CoreBndr
var  -> SDoc -> SDoc
parens (CoreBndr -> SDoc
pprKindedTyVarBndr CoreBndr
var)

      | Bool
otherwise    -> SDoc -> SDoc
parens (SDoc -> Int -> SDoc -> SDoc
hang (CoreBndr -> SDoc
pprIdBndr CoreBndr
var)
                                   2 ([SDoc] -> SDoc
vcat [ SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (CoreBndr -> Type
idType CoreBndr
var)
                                           , SDoc
pp_unf]))
  where
    suppress_sigs :: DynFlags -> Bool
suppress_sigs = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTypeSignatures

    unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo (HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
var)
    pp_unf :: SDoc
pp_unf | Unfolding -> Bool
hasSomeUnfolding Unfolding
unf_info = String -> SDoc
text "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 :: CoreBndr -> SDoc
pprTypedLetBinder binder :: CoreBndr
binder
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    case () of
    _
      | CoreBndr -> Bool
isTyVar CoreBndr
binder                         -> CoreBndr -> SDoc
pprKindedTyVarBndr CoreBndr
binder
      | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressTypeSignatures DynFlags
dflags -> CoreBndr -> SDoc
pprIdBndr CoreBndr
binder
      | Bool
otherwise                              -> SDoc -> Int -> SDoc -> SDoc
hang (CoreBndr -> SDoc
pprIdBndr CoreBndr
binder) 2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (CoreBndr -> Type
idType CoreBndr
binder))

pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr :: CoreBndr -> SDoc
pprKindedTyVarBndr tyvar :: CoreBndr
tyvar
  = String -> SDoc
text "@" SDoc -> SDoc -> SDoc
<+> CoreBndr -> SDoc
pprTyVar CoreBndr
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 :: CoreBndr -> SDoc
pprIdBndr id :: CoreBndr
id = CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
id SDoc -> SDoc -> SDoc
<+> IdInfo -> SDoc
pprIdBndrInfo (HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
idInfo CoreBndr
id)

pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info :: IdInfo
info
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    Bool -> SDoc -> SDoc
ppUnless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressIdInfo DynFlags
dflags) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    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
isManyOccs 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 "InlPrag=" SDoc -> SDoc -> SDoc
<> InlinePragma -> SDoc
pprInlineDebug InlinePragma
prag_info)
          , (Bool
has_occ,  String -> SDoc
text "Occ=" SDoc -> SDoc -> SDoc
<> OccInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccInfo
occ_info)
          , (Bool
has_dmd,  String -> SDoc
text "Dmd=" SDoc -> SDoc -> SDoc
<> Demand -> SDoc
forall a. Outputable a => a -> SDoc
ppr Demand
dmd_info)
          , (Bool
has_lbv , String -> SDoc
text "OS=" SDoc -> SDoc -> SDoc
<> OneShotInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr OneShotInfo
lbv_info)
          ]

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

ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo :: CoreBndr -> IdInfo -> SDoc
ppIdInfo id :: CoreBndr
id info :: IdInfo
info
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    Bool -> SDoc -> SDoc
ppUnless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressIdInfo DynFlags
dflags) (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 (CoreBndr -> IdDetails
idDetails CoreBndr
id))
    , (Bool
has_arity,        String -> SDoc
text "Arity=" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
arity)
    , (Bool
has_called_arity, String -> SDoc
text "CallArity=" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
called_arity)
    , (Bool
has_caf_info,     String -> SDoc
text "Caf=" SDoc -> SDoc -> SDoc
<> CafInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CafInfo
caf_info)
    , (Bool
has_str_info,     String -> SDoc
text "Str=" SDoc -> SDoc -> SDoc
<> StrictSig -> SDoc
pprStrictness StrictSig
str_info)
    , (Bool
has_unf,          String -> SDoc
text "Unf=" SDoc -> SDoc -> SDoc
<> Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unfolding
unf_info)
    , (Bool -> Bool
not ([CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CoreRule]
rules), String -> SDoc
text "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 PprCore.pprIdBndr
  where
    pp_scope :: SDoc
pp_scope | CoreBndr -> Bool
isGlobalId CoreBndr
id   = String -> SDoc
text "GblId"
             | CoreBndr -> Bool
isExportedId CoreBndr
id = String -> SDoc
text "LclIdX"
             | Bool
otherwise       = String -> SDoc
text "LclId"

    arity :: Int
arity = IdInfo -> Int
arityInfo IdInfo
info
    has_arity :: Bool
has_arity = Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0

    called_arity :: Int
called_arity = IdInfo -> Int
callArityInfo IdInfo
info
    has_called_arity :: Bool
has_called_arity = Int
called_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 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)

showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes :: [(Bool, SDoc)] -> SDoc
showAttributes stuff :: [(Bool, SDoc)]
stuff
  | [SDoc] -> 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 | (True,d :: SDoc
d) <- [(Bool, SDoc)]
stuff]

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

instance Outputable UnfoldingGuidance where
    ppr :: UnfoldingGuidance -> SDoc
ppr UnfNever  = String -> SDoc
text "NEVER"
    ppr (UnfWhen { ug_arity :: UnfoldingGuidance -> Int
ug_arity = Int
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 "ALWAYS_IF" SDoc -> SDoc -> SDoc
<>
        SDoc -> SDoc
parens (String -> SDoc
text "arity="     SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
arity    SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<>
                String -> SDoc
text "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 "boring_ok=" SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
boring_ok)
    ppr (UnfIfGoodArgs { ug_args :: UnfoldingGuidance -> [Int]
ug_args = [Int]
cs, ug_size :: UnfoldingGuidance -> Int
ug_size = Int
size, ug_res :: UnfoldingGuidance -> Int
ug_res = Int
discount })
      = [SDoc] -> SDoc
hsep [ String -> SDoc
text "IF_ARGS",
               SDoc -> SDoc
brackets ([SDoc] -> SDoc
hsep ((Int -> SDoc) -> [Int] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Int -> SDoc
int [Int]
cs)),
               Int -> SDoc
int Int
size,
               Int -> SDoc
int Int
discount ]

instance Outputable UnfoldingSource where
  ppr :: UnfoldingSource -> SDoc
ppr InlineCompulsory  = String -> SDoc
text "Compulsory"
  ppr InlineStable      = String -> SDoc
text "InlineStable"
  ppr InlineRhs         = String -> SDoc
text "<vanilla>"

instance Outputable Unfolding where
  ppr :: Unfolding -> SDoc
ppr NoUnfolding                = String -> SDoc
text "No unfolding"
  ppr BootUnfolding              = String -> SDoc
text "No unfolding (from boot)"
  ppr (OtherCon cs :: [AltCon]
cs)              = String -> SDoc
text "OtherCon" SDoc -> SDoc -> SDoc
<+> [AltCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [AltCon]
cs
  ppr (DFunUnfolding { df_bndrs :: Unfolding -> [CoreBndr]
df_bndrs = [CoreBndr]
bndrs, df_con :: Unfolding -> DataCon
df_con = DataCon
con, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
       = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "DFun:" SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit "\\")
                SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((CoreBndr -> SDoc) -> [CoreBndr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> CoreBndr -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [CoreBndr]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow)
            2 (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (Annotation CoreBndr -> [CoreExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Annotation CoreBndr
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 "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 "Src="        SDoc -> SDoc -> SDoc
<> UnfoldingSource -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnfoldingSource
src
                , String -> SDoc
text "TopLvl="     SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
top
                , String -> SDoc
text "Value="      SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
hnf
                , String -> SDoc
text "ConLike="    SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
conlike
                , String -> SDoc
text "WorkFree="   SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
wf
                , String -> SDoc
text "Expandable=" SDoc -> SDoc -> SDoc
<> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
exp
                , String -> SDoc
text "Guidance="   SDoc -> SDoc -> SDoc
<> UnfoldingGuidance -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnfoldingGuidance
g ]
      pp_tmpl :: SDoc
pp_tmpl = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
                Bool -> SDoc -> SDoc
ppUnless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressUnfoldings DynFlags
dflags) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text "Tmpl=" SDoc -> SDoc -> SDoc
<+> Annotation CoreBndr
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 rules :: [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 "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 -> [CoreBndr]
ru_bndrs = [CoreBndr]
tpl_vars, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
tpl_args,
                ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
  = SDoc -> Int -> 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)
       4 ([SDoc] -> SDoc
sep [String -> SDoc
text "forall" SDoc -> SDoc -> SDoc
<+>
                  [SDoc] -> SDoc
sep ((CoreBndr -> SDoc) -> [CoreBndr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> CoreBndr -> SDoc
pprCoreBinder BindingSite
LambdaBind) [CoreBndr]
tpl_vars) SDoc -> SDoc -> SDoc
<> SDoc
dot,
               Int -> SDoc -> SDoc
nest 2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep (Annotation CoreBndr -> [CoreExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Annotation CoreBndr
forall b. OutputableBndr b => Expr b -> SDoc
pprArg [CoreExpr]
tpl_args)),
               Int -> SDoc -> SDoc
nest 2 (String -> SDoc
text "=" SDoc -> SDoc -> SDoc
<+> Annotation CoreBndr
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
rhs)
            ])

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

instance Outputable id => Outputable (Tickish id) where
  ppr :: Tickish id -> SDoc
ppr (HpcTick modl :: Module
modl ix :: Int
ix) =
      [SDoc] -> SDoc
hcat [String -> SDoc
text "hpc<",
            Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
modl, SDoc
comma,
            Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ix,
            String -> SDoc
text ">"]
  ppr (Breakpoint ix :: Int
ix vars :: [id]
vars) =
      [SDoc] -> SDoc
hcat [String -> SDoc
text "break<",
            Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ix,
            String -> SDoc
text ">",
            SDoc -> SDoc
parens ([SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((id -> SDoc) -> [id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [id]
vars)))]
  ppr (ProfNote { profNoteCC :: forall id. Tickish id -> CostCentre
profNoteCC = CostCentre
cc,
                  profNoteCount :: forall id. Tickish id -> Bool
profNoteCount = Bool
tick,
                  profNoteScope :: forall id. Tickish id -> Bool
profNoteScope = Bool
scope }) =
      case (Bool
tick,Bool
scope) of
         (True,True)  -> [SDoc] -> SDoc
hcat [String -> SDoc
text "scctick<", CostCentre -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char '>']
         (True,False) -> [SDoc] -> SDoc
hcat [String -> SDoc
text "tick<",    CostCentre -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char '>']
         _            -> [SDoc] -> SDoc
hcat [String -> SDoc
text "scc<",     CostCentre -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentre
cc, Char -> SDoc
char '>']
  ppr (SourceNote span :: RealSrcSpan
span _) =
      [SDoc] -> SDoc
hcat [ String -> SDoc
text "src<", Bool -> RealSrcSpan -> SDoc
pprUserRealSpan Bool
True RealSrcSpan
span, Char -> SDoc
char '>']