X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=864f4bdcb021d2d556a182b1d1115326cff96d67;hb=2d4b82a0a94edeaedd9d0c4b3f023ac8d1d59766;hp=0bd3178951467261cacec4a1c1722443d2414659;hpb=647eb48674623156f7f5b699e4ecee9410ff585f;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 0bd3178..864f4bd 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % %************************************************************************ %* * @@ -9,23 +9,41 @@ \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, - GenId{-instances-}, Id - ) -import IdInfo ( ppIdInfo ) -import Outputable -- quite a few things -import PprEnv -import PprType ( pprParendType, pprTyVarBndr ) +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} %************************************************************************ @@ -34,102 +52,24 @@ import PprType ( pprParendType, pprTyVarBndr ) %* * %************************************************************************ -@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} +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind bind -Printer for unfoldings in interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -pprIfaceUnfolding :: CoreExpr -> SDoc -pprIfaceUnfolding = ppr_expr pprIfaceEnv - -pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr \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 -\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} %************************************************************************ %* * @@ -138,228 +78,307 @@ init_ppr_env tvbndr pbdr pocc %************************************************************************ \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 add_par (Note (SCC cc) expr) + = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) #ifdef DEBUG -ppr_expr pe (Note (Coerce to_ty from_ty) expr) - = \ sty -> - if debugStyle sty && not (ifaceStyle sty) then - sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty, pTy pe from_ty], - ppr_parend_expr pe expr] sty +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_"), pTy pe to_ty], - ppr_parend_expr pe expr] sty + sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty], + pprParendExpr expr] #else -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 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 pe (Note InlineCall expr) - = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr +ppr_expr add_par (Note InlineCall expr) + = add_par (ptext SLIT("__inline_call") <+> pprParendExpr 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} +ppr_expr add_par (Note InlineMe expr) + = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr -\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 ] - where - ppr_alt (lit, expr) - = hang (hsep [pLit pe lit, ptext SLIT("->")]) - 4 (ppr_expr pe expr <> semi) -\end{code} +ppr_expr add_par (Note (CoreNote s) expr) + = add_par $ + sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)], + pprParendExpr expr] -\begin{code} -ppr_default pe NoDefault = empty +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) -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@(DataAlt dc) args + | isTupleTyCon tc + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow + where + ppr_bndr = pprBndr CaseBind + tc = dataConTyCon dc -\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 +ppr_case_pat con args + = ppr con <+> hsep (map ppr_bndr args) <+> arrow + where + ppr_bndr = pprBndr CaseBind + +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}