%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
\begin{code}
module PprCore (
- pprCoreExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings,
- pprGenericBindings
+ pprCoreExpr, pprParendExpr,
+ pprCoreBinding, pprCoreBindings, pprCoreAlt,
+ pprRules
) where
#include "HsVersions.h"
import CoreSyn
-import CostCentre ( showCostCentre )
-import Id ( idType, idInfo, isTupleCon,
- DataCon, GenId{-instances-}, Id
- )
-import IdInfo ( ppIdInfo, ppStrictnessInfo )
-import Literal ( Literal{-instances-} )
-import Outputable -- quite a few things
-import PprEnv
-import PprType ( pprParendType, pprTyVarBndr )
-import PrimOp ( PrimOp{-instances-} )
-import TyVar ( GenTyVar{-instances-} )
-import Unique ( Unique{-instances-} )
-import Util ( panic{-ToDo:rm-} )
+import CostCentre ( pprCostCentreCore )
+import Var ( Var )
+import Id ( Id, idType, isDataConWorkId_maybe, idArity,
+ idInfo, globalIdDetails, isGlobalId, isExportedId
+ )
+import Var ( TyVar, isTyVar, tyVarKind )
+import IdInfo ( IdInfo, megaSeqIdInfo,
+ inlinePragInfo, occInfo, newDemandInfo,
+ lbvarInfo, hasNoLBVarInfo,
+ arityInfo, ppArityInfo,
+ specInfo, pprNewStrictness,
+ workerInfo, ppWorkerInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
+ )
+import NewDemand ( isTop )
+#ifdef OLD_STRICTNESS
+import Id ( idDemandInfo )
+import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
+#endif
+
+import DataCon ( dataConTyCon )
+import TyCon ( tupleTyConBoxity, isTupleTyCon )
+import Type ( pprParendType, pprType, pprParendKind )
+import BasicTypes ( tupleParens, isNoOcc, isAlwaysActive )
+import Util ( lengthIs )
+import Outputable
+import FastString ( mkFastString )
\end{code}
%************************************************************************
%* *
%************************************************************************
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees. They would
-usually be called through some intermediary.
-
-The binder/occ printers take the default ``homogenized'' (see
-@PprEnv@...) @Doc@ and the binder/occ. They can either use the
-homogenized one, or they can ignore it completely. In other words,
-the things passed in act as ``hooks'', getting the last word on how to
-print something.
-
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
-Un-annotated core dumps
-~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBindings :: [CoreBinding] -> SDoc
-pprCoreBinding :: CoreBinding -> SDoc
-pprCoreExpr :: CoreExpr -> SDoc
+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 pprCoreEnv
-pprCoreBinding = pprTopBind pprCoreEnv
-pprCoreExpr = ppr_expr pprCoreEnv
+pprCoreBindings = pprTopBinds
+pprCoreBinding = pprTopBind
-pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
-\end{code}
-
-Printer for unfoldings in interfaces
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
+instance OutputableBndr b => Outputable (Bind b) where
+ ppr bind = ppr_bind bind
-pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
-\end{code}
-
-Generic Core (possibly annotated binders etc)
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-\begin{code}
-pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
-pprGenericBindings = pprTopBinds pprGenericEnv
-
-pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
-pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
-
-pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
-pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
- ppr bind = ppr_bind pprGenericEnv bind
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
- ppr expr = ppr_expr pprGenericEnv expr
-
-instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
- ppr arg = ppr_arg pprGenericArgEnv arg
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
- ppr alts = ppr_alts pprGenericEnv alts
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
- ppr deflt = ppr_default pprGenericEnv deflt
+instance OutputableBndr b => Outputable (Expr b) where
+ ppr expr = pprCoreExpr expr
\end{code}
%************************************************************************
%* *
-\subsection{Instance declarations for Core printing}
-%* *
-%************************************************************************
-
-
-\begin{code}
-init_ppr_env tvbndr pbdr pocc
- = initPprEnv
- (Just ppr) -- literals
- (Just ppr) -- data cons
- (Just ppr_prim) -- primops
- (Just (\ cc -> text (showCostCentre True cc)))
-
- (Just tvbndr) -- tyvar binders
- (Just ppr) -- tyvar occs
- (Just pprParendType) -- types
-
- (Just pbdr) (Just pocc) -- value vars
- where
-
- -- We add a "!" to distinguish Primitive applications from ordinary applications.
- -- But not when printing for interfaces, where they are treated
- -- as ordinary applications
- ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
- ppr prim
- else
- ppr prim <> char '!')
-
-\end{code}
-
-%************************************************************************
-%* *
\subsection{The guts}
%* *
%************************************************************************
\begin{code}
-pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
+pprTopBinds binds = vcat (map pprTopBind binds)
-pprTopBind pe (NonRec binder expr)
- = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
+pprTopBind (NonRec binder expr)
+ = ppr_binding (binder,expr) $$ text ""
-pprTopBind pe (Rec binds)
+pprTopBind (Rec binds)
= vcat [ptext SLIT("Rec {"),
- vcat (map (ppr_binding_pe pe) binds),
+ vcat (map ppr_binding binds),
ptext SLIT("end Rec }"),
text ""]
\end{code}
\begin{code}
-ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
-ppr_bind pe (Rec binds) = vcat (map pp binds)
- where
- pp bind = ppr_binding_pe pe bind <> semi
-
-ppr_binding_pe pe (val_bdr, expr)
- = sep [pValBndr pe LetBind val_bdr,
- nest 2 (equals <+> ppr_expr pe expr)]
+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}
-ppr_parend_expr pe expr
- = let
- parenify
- = case expr of
- Var _ -> id -- leave unchanged
- Lit _ -> id
- _ -> parens -- wraps in parens
- in
- parenify (ppr_expr pe expr)
+pprParendExpr expr = ppr_expr parens expr
+pprCoreExpr expr = ppr_expr noParens expr
+
+noParens :: SDoc -> SDoc
+noParens pp = pp
\end{code}
\begin{code}
-ppr_expr pe (Var name) = pOcc pe name
-ppr_expr pe (Lit lit) = pLit pe lit
-
-ppr_expr pe (Con con args)
- = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
+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 pe (Prim prim args)
- = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
+ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
+
+ppr_expr add_par (Var name) = ppr name
+ppr_expr add_par (Lit lit) = ppr lit
-ppr_expr pe expr@(Lam _ _)
+ppr_expr add_par expr@(Lam _ _)
= let
- (tyvars, vars, body) = collectBinders expr
+ (bndrs, body) = collectBinders expr
in
- hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
- pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
- 4 (ppr_expr pe body)
- where
- pp_vars lam pp [] = empty
- pp_vars lam pp vs
- = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
-
-ppr_expr pe expr@(App fun arg)
- = let
- (final_fun, final_args) = go fun [arg]
- go (App fun arg) args_so_far = go fun (arg:args_so_far)
- go fun args_so_far = (fun, args_so_far)
+ add_par $
+ hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+ 2 (pprCoreExpr body)
+
+ppr_expr add_par expr@(App fun arg)
+ = 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 pprArg val_args))
in
- hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
-
-ppr_expr pe (Case expr alts)
- | only_one_alt alts
- -- johan thinks that single case patterns should be on same line as case,
- -- and no indent; all sane persons agree with him.
- = let
- ppr_bndr = pValBndr pe CaseBind
-
- ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
- ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
- ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
- ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
- = hsep [pCon pe con,
- hsep (map ppr_bndr params),
- ppr_arrow]
-
- ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
- ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
- ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
- ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
-
-
- ppr_arrow = ptext SLIT(" ->")
- in
- sep
- [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
- (<>) (ppr_rhs alts) (text ";}")]
-
- | otherwise -- default "case" printing
- = sep
- [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
- nest 2 (ppr_alts pe alts),
- text "}"]
+ 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
+
+ other -> add_par (hang (ppr f) 2 pp_args)
+
+ other -> 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)),
+ hsep [ptext SLIT("of"),
+ ppr_bndr var,
+ char '{',
+ ppr_case_pat con args
+ ]],
+ pprCoreExpr rhs,
+ char '}'
+ ]
where
- pp_keyword = case alts of
- AlgAlts _ _ -> ptext SLIT("case")
- PrimAlts _ _ -> ptext SLIT("case#")
+ 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 pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
- = vcat [
- hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
- nest 2 (ppr_expr pe rhs),
+{-
+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"),
- ppr_expr pe body ]
+ pprCoreExpr body ]
+-}
-ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
- = ($$)
- (hang (ptext SLIT("let {"))
- 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
- 4 (ppr_expr pe rhs),
- ptext SLIT("} in")]))
- (ppr_expr pe expr)
+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 pe (Let bind expr)
- = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
- hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
+ppr_expr add_par (Let bind expr)
+ = add_par $
+ sep [hang (ptext keyword) 2 (ppr_bind bind),
+ hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
where
keyword = case bind of
- Rec _ -> SLIT("_letrec_ {")
+ Rec _ -> SLIT("__letrec {")
NonRec _ _ -> SLIT("let {")
-ppr_expr pe (Note (SCC cc) expr)
- = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
- ppr_parend_expr pe expr ]
-
-ppr_expr pe (Note (Coerce to_ty from_ty) expr)
- = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
- ppr_parend_expr pe expr]
-
-ppr_expr pe (Note InlineCall expr)
- = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
-
-only_one_alt (AlgAlts [] (BindDefault _ _)) = True
-only_one_alt (AlgAlts (_:[]) NoDefault) = True
-only_one_alt (PrimAlts [] (BindDefault _ _)) = True
-only_one_alt (PrimAlts (_:[]) NoDefault) = True
-only_one_alt _ = False
-\end{code}
-
-\begin{code}
-ppr_alts pe (AlgAlts alts deflt)
- = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
- where
- ppr_arrow = ptext SLIT("->")
- ppr_bndr = pValBndr pe CaseBind
-
- ppr_alt (con, params, expr)
- = hang (if isTupleCon con then
- hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
- ppr_arrow]
- else
- hsep [pCon pe con,
- hsep (map ppr_bndr params),
- ppr_arrow]
- )
- 4 (ppr_expr pe expr <> semi)
-
-ppr_alts pe (PrimAlts alts deflt)
- = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
+ppr_expr add_par (Note (SCC cc) expr)
+ = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
+
+#ifdef DEBUG
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
+ = add_par $
+ getPprStyle $ \ sty ->
+ if debugStyle sty then
+ sep [ptext SLIT("__coerce") <+>
+ sep [pprParendType to_ty, pprParendType from_ty],
+ pprParendExpr expr]
+ else
+ sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty],
+ pprParendExpr expr]
+#else
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)],
+ pprParendExpr expr]
+#endif
+
+ppr_expr add_par (Note InlineCall expr)
+ = add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr)
+
+ppr_expr add_par (Note InlineMe expr)
+ = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
+
+ppr_expr add_par (Note (CoreNote s) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
+ pprParendExpr expr]
+
+pprCoreAlt (con, args, rhs)
+ = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
+
+ppr_case_pat con@(DataAlt dc) args
+ | isTupleTyCon tc
+ = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
where
- ppr_alt (lit, expr)
- = hang (hsep [pLit pe lit, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\end{code}
-
-\begin{code}
-ppr_default pe NoDefault = empty
+ ppr_bndr = pprBndr CaseBind
+ tc = dataConTyCon dc
-ppr_default pe (BindDefault val_bdr expr)
- = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\end{code}
+ppr_case_pat con args
+ = ppr con <+> hsep (map ppr_bndr args) <+> arrow
+ where
+ ppr_bndr = pprBndr CaseBind
-\begin{code}
-ppr_arg pe (LitArg lit) = pLit pe lit
-ppr_arg pe (VarArg v) = pOcc pe v
-ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
+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}
--- Used for printing dump info
+instance OutputableBndr Var where
+ pprBndr = pprCoreBinder
+
+pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- = vcat [sig, pragmas, ppr binder]
+ = vcat [sig, pprIdDetails binder, pragmas]
where
sig = pprTypedBinder binder
- pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
+ pragmas = ppIdInfo binder (idInfo binder)
-pprCoreBinder LambdaBind binder = pprTypedBinder binder
-pprCoreBinder CaseBind binder = ppr binder
+-- Lambda bound type variables are preceded by "@"
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
+-- Case bound things don't get a signature or a herald
+pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
--- Used for printing interface-file unfoldings
-pprIfaceBinder CaseBind binder = ppr binder
-pprIfaceBinder other binder = pprTypedBinder binder
+pprUntypedBinder binder
+ | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
+ | otherwise = pprIdBndr binder
pprTypedBinder binder
- = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
- -- The space before the :: is important; it helps the lexer
- -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
- --
- -- It's important that the type is parenthesised too, at least when
- -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+ | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
+ | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
+
+pprTyVarBndr :: TyVar -> SDoc
+pprTyVarBndr tyvar
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ hsep [ppr tyvar, dcolon, pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
+ else
+ ppr tyvar
+ where
+ 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 = ppr id <+> pprIdBndrInfo (idInfo id)
+
+pprIdBndrInfo info
+ = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
+ where
+ prag_info = inlinePragInfo info
+ occ_info = occInfo info
+ dmd_info = newDemandInfo info
+ lbv_info = lbvarInfo info
+
+ no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
+ (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
+ hasNoLBVarInfo lbv_info
+
+ doc | no_info = empty
+ | otherwise
+ = brackets $ hcat [ppr prag_info, ppr occ_info,
+ ppr dmd_info, ppr lbv_info
+#ifdef OLD_STRICTNESS
+ , ppr (demandInfo id)
+#endif
+ ]
+\end{code}
+
+
+\begin{code}
+pprIdDetails :: Id -> SDoc
+pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
+ | isExportedId id = ptext SLIT("[Exported]")
+ | otherwise = empty
+
+ppIdInfo :: Id -> IdInfo -> SDoc
+ppIdInfo b info
+ = brackets $
+ vcat [ ppArityInfo a,
+ ppWorkerInfo (workerInfo info),
+ ppCafInfo (cafInfo info),
+#ifdef OLD_STRICTNESS
+ ppStrictnessInfo s,
+ ppCprInfo m,
+#endif
+ pprNewStrictness (newStrictnessInfo info),
+ if null rules then empty
+ else 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
+ a = arityInfo info
+#ifdef OLD_STRICTNESS
+ s = strictnessInfo info
+ m = cprInfo info
+#endif
+ rules = specInfoRules (specInfo info)
+\end{code}
+
+
+\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 })
+ = doubleQuotes (ftext name) <+> ppr act <+>
+ 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)
+ ] <+> semi
\end{code}
projects / ghc-hetmet.git / blobdiff