% % (c) The University of Glasgow 2006 % (c) The AQUA Project, Glasgow University, 1996-1998 % Printing of Core syntax \begin{code}

    module PprCore (
    	pprCoreExpr, pprParendExpr,
    	pprCoreBinding, pprCoreBindings, pprCoreAlt,
    	pprRules
        ) where

    import CoreSyn
    import CostCentre
    import Var
    import Id
    import IdInfo
    import Demand
    import DataCon
    import TyCon
    import Type
    import Coercion
    import StaticFlags
    import BasicTypes
    import Util
    import Outputable
    import FastString
    import Data.Maybe

\end{code} %************************************************************************ %* * \subsection{Public interfaces for Core printing (excluding instances)} %* * %************************************************************************ @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code}

    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

\end{code} %************************************************************************ %* * \subsection{The guts} %* * %************************************************************************ \begin{code}

    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]

\end{code} \begin{code}

    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)

\end{code} \begin{code}

    pprParendExpr   expr = ppr_expr parens expr
    pprCoreExpr expr = ppr_expr noParens expr

    noParens :: SDoc -> SDoc
    noParens pp = pp

\end{code} \begin{code}

    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 (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty)	-- Wierd

    ppr_expr _       (Var name) = ppr name
    ppr_expr _       (Lit lit)  = ppr lit

    ppr_expr add_par (Cast expr co)
      = add_par $
        sep [pprParendExpr expr,
    	 ptext (sLit "`cast`") <+> pprCo co]
      where
        pprCo co | opt_SuppressCoercions = ptext (sLit "...")
                 | otherwise = parens
                             $ sep [ppr co, dcolon <+> pprEqPred (coercionKind 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 (tupleTyConBoxity 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)])
      = 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]
    	  ],
    	 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 (sep (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 (Note (SCC cc) expr)
      = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])

    ppr_expr add_par (Note (CoreNote s) expr)
      = add_par $
        sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
             pprParendExpr expr]

    pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
    pprCoreAlt (con, args, rhs)
      = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)

    ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
    ppr_case_pat (DataAlt dc) args
      | isTupleTyCon tc
      = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
      where
        ppr_bndr = pprBndr CaseBind
        tc = dataConTyCon dc

    ppr_case_pat con args
      = ppr con <+> sep (map ppr_bndr args) <+> arrow
      where
        ppr_bndr = pprBndr CaseBind

    pprArg :: OutputableBndr a => Expr a -> SDoc
    pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
    pprArg expr      = pprParendExpr expr

\end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code}

    instance OutputableBndr Var where
      pprBndr = pprCoreBinder

    pprCoreBinder :: BindingSite -> Var -> SDoc
    pprCoreBinder LetBind binder
      | isTyCoVar binder = pprKindedTyVarBndr binder
      | otherwise      = pprTypedBinder binder $$
    		     ppIdInfo binder (idInfo binder)

    -- Lambda bound type variables are preceded by "@"
    pprCoreBinder bind_site bndr
      = getPprStyle $ \ sty ->
        pprTypedLCBinder bind_site (debugStyle sty) bndr

    pprUntypedBinder :: Var -> SDoc
    pprUntypedBinder binder
      | isTyCoVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
      | otherwise      = pprIdBndr binder

    pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
    -- For lambda and case binders, show the unfolding info (usually none)
    pprTypedLCBinder bind_site debug_on var
      | not debug_on && isDeadBinder var    = char '_'
      | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
      | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
      | otherwise = parens (hang (pprIdBndr var)
                               2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
                  where
    		unf_info = unfoldingInfo (idInfo var)
                    pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
                           | otherwise                 = empty

    pprTypedBinder :: Var -> SDoc
    -- Print binder with a type or kind signature (not paren'd)
    pprTypedBinder binder
      | isTyCoVar binder  = pprKindedTyVarBndr 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 "@") <+> ppr tyvar <> opt_kind
      where
        opt_kind 	-- Print the kind if not *
    	| isLiftedTypeKind kind = empty
    	| otherwise = dcolon <> pprKind kind
        kind = tyVarKind 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
      = 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  = lbvarInfo info

        has_prag = not (isDefaultInlinePragma prag_info)
        has_occ  = not (isNoOcc occ_info)
        has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
        has_lbv  = not (hasNoLBVarInfo 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 "Lbv=") <> ppr lbv_info)
    	  ]

\end{code} ----------------------------------------------------- -- IdDetails and IdInfo ----------------------------------------------------- \begin{code}

    ppIdInfo :: Id -> IdInfo -> SDoc
    ppIdInfo id info
      = showAttributes
        [ (True, pp_scope <> ppr (idDetails id))
        , (has_arity,      ptext (sLit "Arity=") <> int arity)
        , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
        , (has_strictness, 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, lbvar 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

        caf_info = cafInfo info
        has_caf_info = not (mayHaveCafRefs caf_info)

        str_info = strictnessInfo info
        has_strictness = isJust str_info

        unf_info = unfoldingInfo info
        has_unf = hasSomeUnfolding unf_info

        rules = specInfoRules (specInfo info)

    showAttributes :: [(Bool,SDoc)] -> SDoc
    showAttributes stuff
      | null docs = empty
      | otherwise = brackets (sep (punctuate comma docs))
      where
        docs = [d | (True,d) <- stuff]

\end{code} ----------------------------------------------------- -- Unfolding and UnfoldingGuidance ----------------------------------------------------- \begin{code}

    instance Outputable UnfoldingGuidance where
        ppr UnfNever  = ptext (sLit "NEVER")
        ppr (UnfWhen unsat_ok boring_ok)
          = ptext (sLit "ALWAYS_IF") <>
            parens (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 (InlineWrapper w) = ptext (sLit "Worker=") <> ppr w
      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 ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
                                       <+> ppr con <+> brackets (pprWithCommas ppr ops)
      ppr (CoreUnfolding { uf_src = src
                         , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
                         , uf_is_conlike=conlike, uf_is_cheap=cheap
          		     , uf_expandable=exp, uf_guidance=g, uf_arity=arity})
    	= 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 "Arity=")      <> int arity
                    , ptext (sLit "Value=")      <> ppr hnf
                    , ptext (sLit "ConLike=")    <> ppr conlike
                    , ptext (sLit "Cheap=")      <> ppr cheap
                    , 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!

    instance Outputable e => Outputable (DFunArg e) where
      ppr (DFunPolyArg e)  = braces (ppr e)
      ppr (DFunConstArg e) = ppr e
      ppr (DFunLamArg i)   = char '<' <> int i <> char '>'

\end{code} ----------------------------------------------------- -- Rules ----------------------------------------------------- \begin{code}

    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") <+> braces (sep (map pprTypedBinder tpl_vars)),
    	       nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
    	       nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs)
    	    ])

\end{code}