X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=bed901bbd3b750251b4f1080cc222eef88ff2a6a;hb=2ecf1c9f639dc75f1078e88c2e551116923f742a;hp=fd2e03d31f25857035884c0ba435f78fb49ab7cf;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index fd2e03d..bed901b 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 % %************************************************************************ %* * @@ -8,41 +8,33 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module PprCore ( - pprCoreExpr, - pprCoreBinding, - pprBigCoreBinder, - pprTypedCoreBinder - - -- these are here to make the instances go in 0.26: -#if __GLASGOW_HASKELL__ <= 30 - , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts - , GenCoreCaseDefault, GenCoreArg -#endif + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprIdBndr, + pprCoreBinding, pprCoreBindings, + pprCoreRules, pprCoreRule, pprIdCoreRule ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn -import CostCentre ( showCostCentre ) -import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, DataCon(..), GenId{-instances-} +import CostCentre ( pprCostCentreCore ) +import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, + idInfo, idInlinePragma, idDemandInfo, idOccInfo + ) +import Var ( isTyVar ) +import IdInfo ( IdInfo, megaSeqIdInfo, + arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, + specInfo, cprInfo, ppCprInfo, + strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, + workerInfo, ppWorkerInfo ) -import IdInfo ( ppIdInfo, StrictnessInfo(..) ) -import Literal ( Literal{-instances-} ) -import Name ( isSymLexeme ) -import Outputable -- quite a few things +import DataCon ( dataConTyCon ) +import TyCon ( tupleTyConBoxity, isTupleTyCon ) +import PprType ( pprParendType, pprTyVarBndr ) +import BasicTypes ( tupleParens ) import PprEnv -import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} ) -import PprStyle ( PprStyle(..) ) -import Pretty -import PrimOp ( PrimOp{-instances-} ) -import TyVar ( GenTyVar{-instances-} ) -import Unique ( Unique{-instances-} ) -import Usage ( GenUsage{-instances-} ) -import Util ( panic{-ToDo:rm-} ) +import Outputable \end{code} %************************************************************************ @@ -57,100 +49,41 @@ function for ``major'' val_bdrs (those next to equal signs :-), usually be called through some intermediary. The binder/occ printers take the default ``homogenized'' (see -@PprEnv@...) @Pretty@ and the binder/occ. They can either use the +@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} -pprCoreBinding :: PprStyle -> CoreBinding -> Pretty - -pprGenCoreBinding - :: (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees - -> GenCoreBinding bndr occ tyvar uvar - -> Pretty - -pprGenCoreBinding sty pbdr1 pbdr2 pocc bind - = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind - -init_ppr_env sty pbdr1 pbdr2 pocc - = initPprEnv sty - (Just (ppr sty)) -- literals - (Just (ppr sty)) -- data cons - (Just (ppr sty)) -- primops - (Just (\ cc -> ppStr (showCostCentre sty True cc))) - (Just (ppr sty)) -- tyvars - (Just (ppr sty)) -- usage vars - (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars - (Just (pprParendGenType sty)) -- types - (Just (ppr sty)) -- usages - --------------- -pprCoreBinding sty (NonRec binder expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) - -pprCoreBinding sty (Rec binds) - = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"), - ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end plain Rec -}")] - where - ppr_bind (binder, expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) +pprCoreBindings :: [CoreBind] -> SDoc +pprCoreBinding :: CoreBind -> SDoc +pprCoreExpr :: CoreExpr -> SDoc +pprParendExpr :: CoreExpr -> SDoc + +pprCoreBindings = pprTopBinds pprCoreEnv +pprCoreBinding = pprTopBind pprCoreEnv +pprCoreExpr = ppr_noparend_expr pprCoreEnv +pprParendExpr = ppr_parend_expr pprCoreEnv +pprArg = ppr_arg pprCoreEnv + +pprCoreEnv = initCoreEnv pprCoreBinder \end{code} +Printer for unfoldings in interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprCoreExpr - :: PprStyle - -> (Id -> Pretty) -- to print "major" val_bdrs - -> (Id -> Pretty) -- to print "minor" val_bdrs - -> (Id -> Pretty) -- to print bindees - -> CoreExpr - -> Pretty -pprCoreExpr = pprGenCoreExpr - -pprGenCoreExpr, pprParendCoreExpr - :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees - -> GenCoreExpr bndr occ tyvar uvar - -> Pretty - -pprGenCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr - -pprParendCoreExpr sty pbdr1 pbdr2 pocc expr - = let - parenify - = case expr of - Var _ -> id -- leave unchanged - Lit _ -> id - _ -> ppParens -- wraps in parens - in - parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) - -ppr_core_arg sty pocc arg - = ppr_arg (init_ppr_env sty pocc pocc pocc) arg +instance Outputable b => Outputable (Bind b) where + ppr bind = ppr_bind pprGenericEnv bind -ppr_core_alts sty pbdr1 pbdr2 pocc alts - = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts +instance Outputable b => Outputable (Expr b) where + ppr expr = ppr_noparend_expr pprGenericEnv expr -ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt +pprGenericEnv :: Outputable b => PprEnv b +pprGenericEnv = initCoreEnv (\site -> ppr) \end{code} %************************************************************************ @@ -159,222 +92,287 @@ ppr_core_default sty pbdr1 pbdr2 pocc deflt %* * %************************************************************************ + \begin{code} -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreBinding bndr occ tyvar uvar) where - ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreExpr bndr occ tyvar uvar) where - ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr - -instance - (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => - Outputable (GenCoreArg occ tyvar uvar) where - ppr sty arg = ppr_core_arg sty (ppr sty) arg - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where - ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts - -instance - (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar) - => - Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where - ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt +initCoreEnv pbdr + = initPprEnv + (Just pprCostCentreCore) -- Cost centres + + (Just ppr) -- tyvar occs + (Just pprParendType) -- types + + (Just pbdr) (Just ppr) -- value vars + -- Use pprIdBndr for this last one as a debugging device. \end{code} %************************************************************************ %* * -\subsection{Workhorse routines (...????...)} +\subsection{The guts} %* * %************************************************************************ \begin{code} -ppr_bind pe (NonRec val_bdr expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe expr) - -ppr_bind pe (Rec binds) - = ppAboves [ ppStr "{- Rec -}", - ppAboves (map ppr_pair binds), - ppStr "{- end Rec -}" ] - where - ppr_pair (val_bdr, expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe expr) +pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) + +pprTopBind pe (NonRec binder expr) + = ppr_binding_pe pe (binder,expr) $$ text "" + +pprTopBind pe (Rec binds) + = vcat [ptext SLIT("Rec {"), + vcat (map (ppr_binding_pe pe) binds), + ptext SLIT("end Rec }"), + text ""] \end{code} \begin{code} -ppr_parend_expr pe expr - = let - parenify - = case expr of - Var _ -> id -- leave unchanged - Lit _ -> id - _ -> ppParens -- wraps in parens - in - parenify (ppr_expr pe expr) +ppr_bind :: PprEnv b -> Bind b -> SDoc + +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 :: PprEnv b -> (b, Expr b) -> SDoc +ppr_binding_pe pe (val_bdr, expr) + = sep [pBndr pe LetBind val_bdr, + nest 2 (equals <+> ppr_noparend_expr pe expr)] \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 []) = pCon pe con +ppr_parend_expr pe expr = ppr_expr parens pe expr +ppr_noparend_expr pe expr = ppr_expr noParens pe expr -ppr_expr pe (Con con args) - = ppHang (ppBesides [pCon pe con, ppChar '!']) - 4 (ppSep (map (ppr_arg pe) args)) +noParens :: SDoc -> SDoc +noParens pp = pp +\end{code} -ppr_expr pe (Prim prim args) - = ppHang (ppBesides [pPrim pe prim, ppChar '!']) - 4 (ppSep (map (ppr_arg pe) args)) +\begin{code} +ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) -ppr_expr pe expr@(Lam _ _) - = let - (uvars, tyvars, vars, body) = collectBinders expr - in - ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars, - pp_vars SLIT("_/\\_") (pTyVar pe) tyvars, - pp_vars SLIT("\\") (pMinBndr pe) vars]) - 4 (ppr_expr pe body) - where - pp_vars lam pp [] = ppNil - pp_vars lam pp vs - = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"] +ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd + +ppr_expr add_par pe (Var name) = pOcc pe name +ppr_expr add_par pe (Lit lit) = ppr lit -ppr_expr pe expr@(App _ _) +ppr_expr add_par pe expr@(Lam _ _) = let - (fun, uargs, targs, vargs) = collectArgs expr + (bndrs, body) = collectBinders expr + in + add_par $ + hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) + 4 (ppr_noparend_expr pe body) + +ppr_expr add_par pe expr@(App fun arg) + = case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map (ppr_arg pe) args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args)) in - ppHang (ppr_parend_expr pe fun) - 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs) - , ppInterleave ppNil (map (pTy pe) targs) - , ppInterleave ppNil (map (ppr_arg pe) vargs) - ]) - -ppr_expr pe (Case expr alts) - = ppSep - [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"], - ppNest 2 (ppr_alts pe alts), - ppStr "}"] + case fun of + Var f -> case isDataConId_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 = length val_args == idArity f + + other -> add_par (hang (pOcc pe f) 4 pp_args) + + other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args) + } + +ppr_expr add_par pe (Case expr var [(con,args,rhs)]) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, + hsep [ptext SLIT("of"), + ppr_bndr var, + char '{', + ppr_case_pat pe con args + ]], + ppr_noparend_expr pe rhs, + char '}' + ] + where + ppr_bndr = pBndr pe CaseBind + +ppr_expr add_par pe (Case expr var alts) + = add_par $ + sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, + ptext SLIT("of") <+> ppr_bndr var <+> char '{'], + nest 4 (sep (punctuate semi (map ppr_alt alts))), + char '}' + ] + where + ppr_bndr = pBndr pe CaseBind + + ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args) + 4 (ppr_noparend_expr pe rhs) -- special cases: let ... in let ... -- ("disgusting" SLPJ) -ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = ppAboves [ - ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals], - ppNest 2 (ppr_expr pe rhs), - ppStr "} in", - ppr_expr pe body ] - -ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = ppAbove - (ppHang (ppStr "let {") - 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe rhs), - ppStr "} in"])) - (ppr_expr pe expr) +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals], + nest 2 (ppr_noparend_expr pe rhs), + ptext SLIT("} in"), + ppr_noparend_expr pe body ] + +ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (ptext SLIT("let {")) + 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) + 4 (ppr_noparend_expr pe rhs), + ptext SLIT("} in")]) + $$ + ppr_noparend_expr pe expr) -- general case (recursive case, too) -ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind), - ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] +ppr_expr add_par pe (Let bind expr) + = add_par $ + sep [hang (ptext keyword) 2 (ppr_bind pe bind), + hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)] + where + keyword = case bind of + Rec _ -> SLIT("__letrec {") + NonRec _ _ -> SLIT("let {") + +ppr_expr add_par pe (Note (SCC cc) expr) + = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr]) + +#ifdef DEBUG +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + getPprStyle $ \ sty -> + if debugStyle sty && not (ifaceStyle sty) then + sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty], + ppr_parend_expr pe expr] + else + sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty], + ppr_parend_expr pe expr] +#else +ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) + = add_par $ + sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)], + ppr_parend_expr pe expr] +#endif -ppr_expr pe (SCC cc expr) - = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], - ppr_parend_expr pe expr ] +ppr_expr add_par pe (Note InlineCall expr) + = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr) -ppr_expr pe (Coerce c ty expr) - = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c], - pTy pe ty, ppr_parend_expr pe expr ] - where - pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v) -\end{code} +ppr_expr add_par pe (Note InlineMe expr) + = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr -\begin{code} -ppr_alts pe (AlgAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] - where - ppr_alt (con, params, expr) - = ppHang (if isTupleCon con then - ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), - ppStr "->"] - else - ppCat [ppr_con con (pCon pe con), - ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] - ) - 4 (ppr_expr pe expr) - where - ppr_con con pp_con - = if isSymLexeme con then ppParens pp_con else pp_con - -ppr_alts pe (PrimAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] +ppr_expr add_par pe (Note (TermUsg u) expr) + = getPprStyle $ \ sty -> + if ifaceStyle sty then + ppr_expr add_par pe expr + else + add_par (ppr u <+> ppr_noparend_expr pe expr) + +ppr_case_pat pe con@(DataAlt dc) args + | isTupleTyCon tc + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where - ppr_alt (lit, expr) - = ppHang (ppCat [pLit pe lit, ppStr "->"]) - 4 (ppr_expr pe expr) -\end{code} + ppr_bndr = pBndr pe CaseBind + tc = dataConTyCon dc -\begin{code} -ppr_default pe NoDefault = ppNil +ppr_case_pat pe con args + = ppr con <+> hsep (map ppr_bndr args) <+> arrow + where + ppr_bndr = pBndr pe CaseBind -ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"]) - 4 (ppr_expr pe expr) -\end{code} +ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty +ppr_arg pe expr = ppr_parend_expr pe expr -\begin{code} -ppr_arg pe (LitArg lit) = pLit pe lit -ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = pTy pe ty -ppr_arg pe (UsageArg use) = pUse pe use +arrow = ptext SLIT("->") \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code} -pprBigCoreBinder sty binder - = ppAboves [sig, pragmas, ppr sty binder] +-- Used for printing dump info +pprCoreBinder LetBind binder + = vcat [sig, pragmas, ppr binder] where - sig = ifnotPprShowAll sty ( - ppHang (ppCat [ppr sty binder, ppStr "::"]) - 4 (ppr sty (idType binder))) + sig = pprTypedBinder binder + pragmas = ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder LambdaBind bndr = pprTypedBinder bndr + +-- Case bound things don't get a signature or a herald +pprCoreBinder CaseBind bndr = pprUntypedBinder bndr + +pprUntypedBinder binder + | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder + | otherwise = pprIdBndr binder + +pprTypedBinder binder + | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder + | otherwise = pprIdBndr binder <+> dcolon <+> 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) -> ... + +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr id = ppr id <+> + (megaSeqIdInfo (idInfo id) `seq` + -- Useful for poking on black holes + ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> + ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id)) +\end{code} - pragmas = - ifnotPprForUser sty - (ppIdInfo sty binder True{-specs, please-} id nullIdEnv - (getIdInfo binder)) -pprBabyCoreBinder sty binder - = ppCat [ppr sty binder, pp_strictness] +\begin{code} +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo b info + = hsep [ + ppFlavourInfo (flavourInfo info), + ppArityInfo a, + ppWorkerInfo (workerInfo info), + ppStrictnessInfo s, + ppCafInfo c, + ppCprInfo m, + pprCoreRules b p + -- Inline pragma, occ, demand, lbvar info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr + ] where - pp_strictness - = case (getIdStrictness binder) of - NoStrictnessInfo -> ppNil - BottomGuaranteed -> ppStr "{- _!_ -}" - StrictnessInfo xx _ -> - panic "PprCore:pp_strictness:StrictnessInfo:ToDo" - -- ppStr ("{- " ++ (showList xx "") ++ " -}") - -pprTypedCoreBinder sty binder - = ppBesides [ppLparen, ppCat [ppr sty binder, - ppStr "::", ppr sty (idType binder)], - ppRparen] + a = arityInfo info + s = strictnessInfo info + c = cafInfo info + m = cprInfo info + p = specInfo info +\end{code} + + +\begin{code} +pprCoreRules :: Id -> CoreRules -> SDoc +pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) + +pprIdCoreRule :: IdCoreRule -> SDoc +pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule + +pprCoreRule :: SDoc -> CoreRule -> SDoc +pprCoreRule pp_fn (BuiltinRule _) + = ifPprDebug (ptext SLIT("A built in rule")) + +pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) + = doubleQuotes (ptext name) <+> + sep [ + ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), + nest 4 (pp_fn <+> sep (map pprArg tpl_args)), + nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs) + ] <+> semi \end{code}