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