content: {-
  (c) The University of Glasgow 2006
  (c) The AQUA Project, Glasgow University, 1996-1998
  
  
  Printing of Core syntax
  -}
  
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  module Eta.Core.PprCore (
          pprCoreExpr, pprParendExpr,
          pprCoreBinding, pprCoreBindings, pprCoreAlt,
          pprRules
      ) where
  
  import Eta.Core.CoreSyn
  import Eta.Core.CoreSeq
  import Eta.BasicTypes.Literal( pprLiteral )
  import Eta.BasicTypes.Name( pprInfixName, pprPrefixName )
  import Eta.BasicTypes.Var
  import Eta.BasicTypes.Id
  import Eta.BasicTypes.IdInfo
  import Eta.BasicTypes.Demand
  import Eta.BasicTypes.DataCon
  import Eta.Types.TyCon
  import Eta.Types.Type
  import Eta.Types.Coercion
  import Eta.Main.DynFlags
  import Eta.BasicTypes.BasicTypes
  import Eta.Utils.Util
  import Eta.Utils.Outputable
  import Eta.Utils.FastString
  import Eta.BasicTypes.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 = pprTopBinds
  pprCoreBinding  = pprTopBind
  
  instance OutputableBndr b => Outputable (Bind b) where
      ppr bind = ppr_bind bind
  
  instance OutputableBndr b => Outputable (Expr b) where
      ppr expr = pprCoreExpr expr
  
  {-
  ************************************************************************
  *                                                                      *
  \subsection{The guts}
  *                                                                      *
  ************************************************************************
  -}
  
  pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
  pprTopBinds binds = vcat (map pprTopBind binds)
  
  pprTopBind :: OutputableBndr a => Bind a -> SDoc
  pprTopBind (NonRec binder expr)
   = ppr_binding (binder,expr) $$ blankLine
  
  pprTopBind (Rec [])
    = ptext (sLit "Rec { }")
  pprTopBind (Rec (b:bs))
    = vcat [ptext (sLit "Rec {"),
            ppr_binding b,
            vcat [blankLine $$ ppr_binding b | b <- bs],
            ptext (sLit "end Rec }"),
            blankLine]
  
  ppr_bind :: OutputableBndr b => Bind b -> SDoc
  
  ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
  ppr_bind (Rec binds)           = vcat (map pp binds)
                                 where
                                   pp bind = ppr_binding bind <> semi
  
  ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
  ppr_binding (val_bdr, expr)
    = pprBndr LetBind val_bdr $$
      hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
  
  pprParendExpr expr = ppr_expr parens expr
  pprCoreExpr   expr = ppr_expr noParens expr
  
  noParens :: SDoc -> SDoc
  noParens pp = pp
  
  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 _       (Var name)    = ppr name
  ppr_expr add_par (Type ty)     = add_par (ptext (sLit "TYPE") <+> ppr ty)       -- Weird
  ppr_expr add_par (Coercion co) = add_par (ptext (sLit "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,
           ptext (sLit "`cast`") <+> pprCo co]
    where
      pprCo co = sdocWithDynFlags $ \dflags ->
                 if gopt Opt_SuppressCoercions dflags
                 then ptext (sLit "...")
                 else parens $
                          sep [ppr co, dcolon <+> ppr (coercionType co)]
  
  
  ppr_expr add_par expr@(Lam _ _)
    = let
          (bndrs, body) = collectBinders expr
      in
      add_par $
      hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
           2 (pprCoreExpr body)
  
  ppr_expr add_par expr@(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 = sep (punctuate comma (map pprCoreExpr val_args))
      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 && isTupleTyCon tc
                             -> tupleParens (tupleTyConSort tc) pp_tup_args
                             where
                               tc        = dataConTyCon dc
                               saturated = val_args `lengthIs` idArity f
  
                     _ -> add_par (hang (ppr f) 2 pp_args)
  
          _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
      }
  
  ppr_expr add_par (Case expr var ty [(con,args,rhs)])
    = sdocWithDynFlags $ \dflags ->
      if gopt Opt_PprCaseAsLet dflags
      then add_par $  -- See Note [Print case as let]
           sep [ sep [ ptext (sLit "let! {")
                       <+> ppr_case_pat con args
                       <+> ptext (sLit "~")
                       <+> ppr_bndr var
                     , ptext (sLit "<-") <+> ppr_expr id expr
                       <+> ptext (sLit "} in") ]
               , pprCoreExpr rhs
               ]
      else add_par $
           sep [sep [ptext (sLit "case") <+> pprCoreExpr expr,
                     ifPprDebug (braces (ppr ty)),
                     sep [ptext (sLit "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)
    = add_par $
      sep [sep [ptext (sLit "case")
                  <+> pprCoreExpr expr
                  <+> ifPprDebug (braces (ppr ty)),
                ptext (sLit "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 [ptext (sLit "let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
        nest 2 (pprCoreExpr rhs),
        ptext (sLit "} in"),
        pprCoreExpr body ]
  
  ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
    = add_par
      (hang (ptext (sLit "let {"))
            2 (hsep [ppr_binding (val_bdr,rhs),
                     ptext (sLit "} in")])
       $$
       pprCoreExpr expr)
  -}
  
  -- General case (recursive case, too)
  ppr_expr add_par (Let bind expr)
    = add_par $
      sep [hang (ptext keyword) 2 (ppr_bind bind <+> ptext (sLit "} in")),
           pprCoreExpr expr]
    where
      keyword = case bind of
                  Rec _      -> (sLit "letrec {")
                  NonRec _ _ -> (sLit "let {")
  
  ppr_expr add_par (Tick tickish expr)
    = sdocWithDynFlags $ \dflags ->
    if gopt Opt_PprShowTicks dflags
    then add_par (sep [ppr tickish, pprCoreExpr expr])
    else ppr_expr add_par expr
  
  pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
  pprCoreAlt (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
    | isTupleTyCon tc
    = tupleParens (tupleTyConSort tc) (hsep (punctuate comma (map ppr_bndr args)))
    where
      ppr_bndr = pprBndr CaseBind
      tc = dataConTyCon dc
  
  ppr_case_pat con args
    = ppr con <+> (fsep (map ppr_bndr args))
    where
      ppr_bndr = pprBndr CaseBind
  
  
  -- | Pretty print the argument in a function application.
  pprArg :: OutputableBndr a => Expr a -> SDoc
  pprArg (Type ty)
   = sdocWithDynFlags $ \dflags ->
     if gopt Opt_SuppressTypeApplications dflags
     then empty
     else ptext (sLit "@") <+> pprParendType ty
  pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo 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.
  -}
  
  instance OutputableBndr Var where
    pprBndr = pprCoreBinder
    pprInfixOcc  = pprInfixName  . varName
    pprPrefixOcc = pprPrefixName . varName
  
  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
    = getPprStyle $ \ sty ->
      pprTypedLamBinder bind_site (debugStyle sty) bndr
  
  pprUntypedBinder :: Var -> SDoc
  pprUntypedBinder binder
    | isTyVar binder = ptext (sLit "@") <+> 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
    = sdocWithDynFlags $ \dflags ->
      case () of
      _
        | 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
  
        | suppress_sigs dflags    -> pprUntypedBinder var
  
        | isTyVar var  -> parens (pprKindedTyVarBndr var)
  
        | otherwise    -> parens (hang (pprIdBndr var)
                                     2 (vcat [ dcolon <+> pprType (idType var)
                                             , pp_unf]))
    where
      suppress_sigs = gopt Opt_SuppressTypeSignatures
  
      unf_info = unfoldingInfo (idInfo var)
      pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
             | otherwise                 = empty
  
  pprTypedLetBinder :: Var -> SDoc
  -- Print binder with a type or kind signature (not paren'd)
  pprTypedLetBinder binder
    = sdocWithDynFlags $ \dflags ->
      case () of
      _
        | isTyVar binder                         -> pprKindedTyVarBndr binder
        | gopt Opt_SuppressTypeSignatures dflags -> 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
    = ptext (sLit "@") <+> pprTvBndr 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 = ppr id <+> pprIdBndrInfo (idInfo id)
  
  pprIdBndrInfo :: IdInfo -> SDoc
  pprIdBndrInfo info
    = sdocWithDynFlags $ \dflags ->
      if gopt Opt_SuppressIdInfo dflags
      then empty
      else megaSeqIdInfo 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 (isNoOcc occ_info)
      has_dmd   = not $ isTopDmd dmd_info
      has_lbv   = not (hasNoOneShotInfo lbv_info)
  
      doc = showAttributes
            [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
            , (has_occ,  ptext (sLit "Occ=") <> ppr occ_info)
            , (has_dmd,  ptext (sLit "Dmd=") <> ppr dmd_info)
            , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info)
            ]
  
  {-
  -----------------------------------------------------
  --      IdDetails and IdInfo
  -----------------------------------------------------
  -}
  
  ppIdInfo :: Id -> IdInfo -> SDoc
  ppIdInfo id info
    = sdocWithDynFlags $ \dflags ->
      if gopt Opt_SuppressIdInfo dflags
      then empty
      else
      showAttributes
      [ (True, pp_scope <> ppr (idDetails id))
      , (has_arity,        ptext (sLit "Arity=") <> int arity)
      , (has_called_arity, ptext (sLit "CallArity=") <> int called_arity)
      , (has_caf_info,     ptext (sLit "Caf=") <> ppr caf_info)
      , (True,             ptext (sLit "Str=") <> pprStrictness str_info)
      , (has_unf,          ptext (sLit "Unf=") <> ppr unf_info)
      , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
      ]   -- Inline pragma, occ, demand, one-shot info
          -- printed out with all binders (when debug is on);
          -- see PprCore.pprIdBndr
    where
      pp_scope | isGlobalId id   = ptext (sLit "GblId")
               | isExportedId id = ptext (sLit "LclIdX")
               | otherwise       = ptext (sLit "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 = strictnessInfo info
  
      unf_info = unfoldingInfo 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  = ptext (sLit "NEVER")
      ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })
        = ptext (sLit "ALWAYS_IF") <>
          parens (ptext (sLit "arity=")     <> int arity    <> comma <>
                  ptext (sLit "unsat_ok=")  <> ppr unsat_ok <> comma <>
                  ptext (sLit "boring_ok=") <> ppr boring_ok)
      ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })
        = hsep [ ptext (sLit "IF_ARGS"),
                 brackets (hsep (map int cs)),
                 int size,
                 int discount ]
  
  instance Outputable UnfoldingSource where
    ppr InlineCompulsory  = ptext (sLit "Compulsory")
    ppr InlineStable      = ptext (sLit "InlineStable")
    ppr InlineRhs         = ptext (sLit "<vanilla>")
  
  instance Outputable Unfolding where
    ppr NoUnfolding                = ptext (sLit "No unfolding")
    ppr (OtherCon cs)              = ptext (sLit "OtherCon") <+> ppr cs
    ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
         = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\")
                  <+> 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_is_value=hnf
                       , uf_is_conlike=conlike, uf_is_work_free=wf
                       , uf_expandable=exp, uf_guidance=g })
          = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
      where
        pp_info = fsep $ punctuate comma
                  [ ptext (sLit "Src=")        <> ppr src
                  , ptext (sLit "TopLvl=")     <> ppr top
                  , ptext (sLit "Value=")      <> ppr hnf
                  , ptext (sLit "ConLike=")    <> ppr conlike
                  , ptext (sLit "WorkFree=")   <> ppr wf
                  , ptext (sLit "Expandable=") <> ppr exp
                  , ptext (sLit "Guidance=")   <> ppr g ]
        pp_tmpl = ptext (sLit "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!
  
  {-
  -----------------------------------------------------
  --      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})
    = ptext (sLit "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 [ptext (sLit "forall") <+>
                    sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot,
                 nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
                 nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
              ])
  
  {-
  -----------------------------------------------------
  --      Tickish
  -----------------------------------------------------
  -}
  
  instance Outputable id => Outputable (Tickish id) where
    ppr (HpcTick modl ix) =
        hcat [ptext (sLit "hpc<"),
              ppr modl, comma,
              ppr ix,
              ptext (sLit ">")]
    ppr (Breakpoint ix vars) =
        hcat [ptext (sLit "break<"),
              ppr ix,
              ptext (sLit ">"),
              parens (hcat (punctuate comma (map ppr vars)))]
    ppr (ProfNote { profNoteCC = cc,
                    profNoteCount = tick,
                    profNoteScope = scope }) =
        case (tick,scope) of
           (True,True)  -> hcat [ptext (sLit "scctick<"), ppr cc, char '>']
           (True,False) -> hcat [ptext (sLit "tick<"),    ppr cc, char '>']
           _            -> hcat [ptext (sLit "scc<"),     ppr cc, char '>']
    ppr (SourceNote span name) =
        hcat [ptext (sLit name), ptext (sLit " <"), pprUserRealSpan True span, char '>']
  
  {-
  -----------------------------------------------------
  --      Vectorisation declarations
  -----------------------------------------------------
  -}
  
  instance Outputable CoreVect where
    ppr (Vect     var e)               = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
                                           4 (pprCoreExpr e)
    ppr (NoVect   var)                 = ptext (sLit "NOVECTORISE") <+> ppr var
    ppr (VectType False var Nothing)   = ptext (sLit "VECTORISE type") <+> ppr var
    ppr (VectType True  var Nothing)   = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
    ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+>
                                         ppr tc
    ppr (VectType True var (Just tc))  = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
                                         char '=' <+> ppr tc
    ppr (VectClass tc)                 = ptext (sLit "VECTORISE class") <+> ppr tc
    ppr (VectInst var)                 = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
  