X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=9f8a16d3af3fedfaa1a798bfbadc0bd20f8bcec7;hb=30b5ebe424ebae69b162ac3fc547eb14d898535f;hp=e822513a6778e3bcf2c1b96eafdfaf67d22a660c;hpb=ebfe11e7706387b8a445f02dc6166ff067ee7b90;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index e822513..9f8a16d 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,30 @@ %************************************************************************ \begin{code} -#include "HsVersions.h" - module PprCore ( - pprCoreExpr, pprIfaceUnfolding, - pprCoreBinding, pprCoreBindings, - 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, pprIfaceUnfolding, + pprCoreBinding, pprCoreBindings, pprIdBndr, + pprCoreRules, pprCoreRule ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CoreSyn -import CostCentre ( showCostCentre ) -import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, SYN_IE(DataCon), GenId{-instances-}, - SYN_IE(Id) - ) -import IdInfo ( ppIdInfo, ppStrictnessInfo ) -import Literal ( Literal{-instances-} ) -import Name ( OccName ) -import Outputable -- quite a few things +import CostCentre ( pprCostCentreCore ) +import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, getIdOccInfo, Id ) +import Var ( isTyVar ) +import IdInfo ( IdInfo, + arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo, + demandInfo, updateInfo, ppUpdateInfo, specInfo, + strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo, + cprInfo, ppCprInfo, lbvarInfo, + workerInfo, ppWorkerInfo + ) +import Const ( Con(..), DataCon ) +import DataCon ( isTupleCon, isUnboxedTupleCon ) +import PprType ( pprParendType, pprTyVarBndr ) import PprEnv -import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) -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} %************************************************************************ @@ -64,128 +53,43 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. +Un-annotated core dumps +~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprCoreBinding :: PprStyle -> CoreBinding -> Doc -pprCoreBindings :: PprStyle -> [CoreBinding] -> Doc - -pprGenCoreBinding - :: (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Doc) -- to print "major" val_bdrs - -> (bndr -> Doc) -- to print "minor" val_bdrs - -> (occ -> Doc) -- to print bindees - -> GenCoreBinding bndr occ tyvar uvar - -> Doc - -pprGenCoreBinding sty pbdr1 pbdr2 pocc bind - = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind - -init_ppr_env sty tvbndr pbdr1 pbdr2 pocc - = initPprEnv sty - (Just (ppr sty)) -- literals - (Just ppr_con) -- data cons - (Just ppr_prim) -- primops - (Just (\ cc -> text (showCostCentre sty True cc))) - (Just tvbndr) -- tyvar binders - (Just (ppr sty)) -- tyvar occs - (Just (ppr sty)) -- usage vars - (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars - (Just (pprParendGenType sty)) -- types - (Just (ppr sty)) -- usages - where - - ppr_con con = ppr sty con - -{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] - [We can't treat them as ordinary applications because the Con doesn't have - dictionaries in it, whereas the constructor Id does.] +pprCoreBindings :: [CoreBind] -> SDoc +pprCoreBinding :: CoreBind -> SDoc +pprCoreExpr :: CoreExpr -> SDoc +pprParendExpr :: CoreExpr -> SDoc - OLD VERSION: - -- ppr_con is used when printing Con expressions; we add a "!" - -- to distinguish them from ordinary applications. But not when - -- printing for interfaces, where they are treated as ordinary applications - ppr_con con | ifaceStyle sty = ppr sty con - | otherwise = ppr sty con <> char '!' --} +pprCoreBindings = pprTopBinds pprCoreEnv +pprCoreBinding = pprTopBind pprCoreEnv +pprCoreExpr = ppr_expr pprCoreEnv +pprParendExpr = ppr_parend_expr pprCoreEnv - -- 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 | ifaceStyle sty = ppr sty prim - | otherwise = ppr sty prim <> char '!' +pprCoreEnv = initCoreEnv pprCoreBinder +\end{code} --------------- -pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds) +Printer for unfoldings in interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +pprIfaceUnfolding :: CoreExpr -> SDoc +pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv + -- Notice that it's parenthesised -pprCoreBinding sty (NonRec binder expr) - = hang (hsep [pprBigCoreBinder sty binder, equals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) +pprIfaceArg = ppr_arg pprIfaceEnv -pprCoreBinding sty (Rec binds) - = vcat [ptext SLIT("Rec {"), - vcat (map ppr_bind binds), - ptext SLIT("end Rec }")] - where - ppr_bind (binder, expr) - = hang (hsep [pprBigCoreBinder sty binder, equals]) - 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) +pprIfaceEnv = initCoreEnv pprIfaceBinder \end{code} \begin{code} -pprCoreExpr - :: PprStyle - -> (Id -> Doc) -- to print "major" val_bdrs - -> (Id -> Doc) -- to print "minor" val_bdrs - -> (Id -> Doc) -- to print bindees - -> CoreExpr - -> Doc -pprCoreExpr = pprGenCoreExpr - -pprGenCoreExpr, pprParendCoreExpr - :: (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar, - Outputable bndr, - Outputable occ) - => PprStyle - -> (bndr -> Doc) -- to print "major" val_bdrs - -> (bndr -> Doc) -- to print "minor" val_bdrs - -> (occ -> Doc) -- to print bindees - -> GenCoreExpr bndr occ tyvar uvar - -> Doc - -pprGenCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr - -pprParendCoreExpr sty pbdr1 pbdr2 pocc expr - = let - parenify - = case expr of - Var _ -> id -- leave unchanged - Lit _ -> id - _ -> parens -- wraps in parens - in - parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) - --- Printer for unfoldings in interfaces -pprIfaceUnfolding :: CoreExpr -> Doc -pprIfaceUnfolding = ppr_expr env - where - env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) - (pprTypedCoreBinder PprInterface) - (ppr PprInterface) - (ppr PprInterface) - -ppr_core_arg sty pocc arg - = ppr_arg (init_ppr_env sty (ppr 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 (ppr sty) pbdr1 pbdr2 pocc) alts +instance Outputable b => Outputable (Expr b) where + ppr expr = ppr_expr pprGenericEnv expr -ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt +pprGenericEnv :: Outputable b => PprEnv b +pprGenericEnv = initCoreEnv (\site -> ppr) \end{code} %************************************************************************ @@ -194,102 +98,93 @@ 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 = pprQuote sty $ \sty -> - 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 = pprQuote sty $ \sty -> - 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 = pprQuote sty $ \sty -> - 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 = pprQuote sty $ \sty -> - 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 = pprQuote sty $ \sty -> - ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt +initCoreEnv pbdr + = initPprEnv + (Just ppr) -- Constants + (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) - = hang (hsep [pMajBndr pe val_bdr, equals]) - 4 (ppr_expr pe expr) +pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) -ppr_bind pe (Rec binds) - = vcat (map ppr_pair binds) - where - ppr_pair (val_bdr, expr) - = hang (hsep [pMajBndr pe val_bdr, equals]) - 4 (ppr_expr pe expr <> semi) +pprTopBind pe (NonRec binder expr) + = sep [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_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_expr pe 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) + | no_parens = ppr_expr pe expr + | otherwise = parens (ppr_expr pe expr) + where + no_parens = case expr of + Var _ -> True + Con con [] -> True + Con (DataCon dc) _ -> isTupleCon dc + _ -> False \end{code} \begin{code} -ppr_expr pe (Var name) = pOcc pe name -ppr_expr pe (Lit lit) = pLit pe lit +ppr_expr :: PprEnv b -> Expr b -> SDoc -ppr_expr pe (Con con args) - = hang (pCon pe con) - 4 (braces $ sep (map (ppr_arg pe) args)) +ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd + +ppr_expr pe (Var name) = pOcc pe name -ppr_expr pe (Prim prim args) - = hang (pPrim pe prim) - 4 (sep (map (ppr_arg pe) args)) +ppr_expr pe (Con con []) + = ppr con -- Nullary constructors too + +ppr_expr pe (Con (DataCon dc) args) + -- Drop the type arguments and print in (a,b,c) notation + | isTupleCon dc + = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args)))) + | isUnboxedTupleCon dc + = text "(# " <> + hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <> + text " #)" + +ppr_expr pe (Con con args) + = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) = let - (uvars, tyvars, vars, body) = collectBinders expr + (bndrs, body) = collectBinders expr in - hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars, - pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, - pp_vars SLIT("\\") (pMajBndr pe) vars]) + hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) 4 (ppr_expr pe body) - where - pp_vars lam pp [] = empty - pp_vars lam pp vs - = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")] ppr_expr pe expr@(App fun arg) = let @@ -299,143 +194,195 @@ ppr_expr pe expr@(App fun arg) 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_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow - ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe 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 (pMinBndr pe) 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 "}"] +ppr_expr pe (Case expr var [(con,args,rhs)]) + = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, + hsep [ptext SLIT("of"), + ppr_bndr var, + char '{', + ppr_case_pat pe con args + ]], + ppr_expr pe rhs, + char '}' + ] + where + ppr_bndr = pBndr pe CaseBind + +ppr_expr pe (Case expr var alts) + = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr, + ptext SLIT("of") <+> ppr_bndr var <+> char '{'], + nest 4 (sep (punctuate semi (map ppr_alt alts))), + char '}' + ] where - pp_keyword = case alts of - AlgAlts _ _ -> ptext SLIT("case") - PrimAlts _ _ -> ptext SLIT("case#") + ppr_bndr = pBndr pe CaseBind + + ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args) + 4 (ppr_expr pe rhs) -- special cases: let ... in let ... -- ("disgusting" SLPJ) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = vcat [ - hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals], + hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals], nest 2 (ppr_expr pe rhs), ptext SLIT("} in"), ppr_expr pe body ] ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = ($$) - (hang (ptext SLIT("let {")) - 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals]) + = hang (ptext SLIT("let {")) + 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) 4 (ppr_expr pe rhs), - ptext SLIT("} in")])) - (ppr_expr pe expr) + ptext SLIT("} in")]) + $$ + ppr_expr pe 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)] + hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)] where keyword = case bind of - Rec _ -> SLIT("_letrec_ {") + Rec _ -> SLIT("__letrec {") NonRec _ _ -> SLIT("let {") -ppr_expr pe (SCC cc expr) - = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc], - ppr_parend_expr pe expr ] +ppr_expr pe (Note (SCC cc) expr) + = sep [pSCC pe cc, ppr_expr pe expr] + +#ifdef DEBUG +ppr_expr pe (Note (Coerce to_ty from_ty) expr) + = 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 pe (Note (Coerce to_ty from_ty) expr) + = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)], + ppr_parend_expr pe expr] +#endif -ppr_expr pe (Coerce c ty expr) - = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr] +ppr_expr pe (Note InlineCall expr) + = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr + +ppr_expr pe (Note InlineMe expr) + = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr + +ppr_expr pe (Note (TermUsg u) expr) + = \ sty -> + if ifaceStyle sty then + ppr_expr pe expr sty + else + (ppr u <+> ppr_expr pe expr) sty + +ppr_case_pat pe con@(DataCon dc) args + | isTupleCon dc + = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow + | isUnboxedTupleCon dc + = hsep [text "(# " <> + hsep (punctuate comma (map ppr_bndr args)) <> + text " #)", + arrow] where - pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) - -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_bndr = pBndr pe CaseBind -\begin{code} -ppr_alts pe (AlgAlts alts deflt) - = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] +ppr_case_pat pe con args + = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow where - ppr_arrow = ptext SLIT("->") - - ppr_alt (con, params, expr) - = hang (if isTupleCon con then - hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))), - ppr_arrow] - else - hsep [pCon pe con, - hsep (map (pMinBndr pe) 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_bndr = pBndr pe CaseBind -\begin{code} -ppr_default pe NoDefault = empty +ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty +ppr_arg pe expr = ppr_parend_expr pe expr -ppr_default pe (BindDefault val_bdr expr) - = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")]) - 4 (ppr_expr pe expr <> semi) -\end{code} - -\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_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 - = vcat [pragmas, - pprTypedCoreBinder sty binder] +-- Used for printing dump info +pprCoreBinder LetBind binder + = vcat [sig, pragmas, ppr binder] where - pragmas = ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder) + sig = pprTypedBinder binder + pragmas = ppIdInfo (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 + +-- Used for printing interface-file unfoldings +pprIfaceBinder CaseBind binder = pprUntypedBinder binder +pprIfaceBinder other binder = pprTypedBinder binder + +pprUntypedBinder binder + | isTyVar binder = 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 <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdOccInfo id) <+> + ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id)) +\end{code} -pprBabyCoreBinder sty binder - = hsep [ppr sty binder, pp_strictness] + +\begin{code} +ppIdInfo :: IdInfo -> SDoc +ppIdInfo info + = hsep [ + ppFlavourInfo (flavourInfo info), + ppArityInfo a, + ppUpdateInfo u, + ppWorkerInfo (workerInfo info), + ppStrictnessInfo s, + ppr d, + ppCafInfo c, + ppCprInfo m, + ppr (lbvarInfo info), + pprIfaceCoreRules p + -- Inline pragma printed out with all binders; see PprCore.pprIdBndr + ] where - pp_strictness = ppStrictnessInfo sty (getIdStrictness binder) + a = arityInfo info + d = demandInfo info + s = strictnessInfo info + u = updateInfo info + c = cafInfo info + m = cprInfo info + p = specInfo info +\end{code} -pprTypedCoreBinder sty binder - = hsep [ppr sty binder, ptext SLIT("::"), pprParendGenType sty (idType binder)] - -- The space before the :: is important; it helps the lexer - -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. + +\begin{code} +pprCoreRules :: Id -> CoreRules -> SDoc +pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules) + +pprIfaceCoreRules :: CoreRules -> SDoc +pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules) + +pprCoreRule :: Maybe Id -> CoreRule -> SDoc +pprCoreRule maybe_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 pprIfaceArg tpl_args)), + nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs) + ] + where + pp_fn = case maybe_fn of + Just id -> ppr id + Nothing -> empty -- Interface file \end{code}