\begin{code}
module PprCore (
pprCoreExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings
+ pprCoreBinding, pprCoreBindings,
+ pprGenericBindings
) where
#include "HsVersions.h"
import CoreSyn
import CostCentre ( showCostCentre )
-import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
- nullIdEnv, DataCon, GenId{-instances-},
- Id
+import Id ( idType, idInfo, isTupleCon,
+ GenId{-instances-}, Id
)
-import IdInfo ( ppIdInfo, ppStrictnessInfo )
-import Literal ( Literal{-instances-} )
-import Name ( OccName )
+import IdInfo ( ppIdInfo )
import Outputable -- quite a few things
import PprEnv
-import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
-import PrimOp ( PrimOp{-instances-} )
-import TyVar ( GenTyVar{-instances-} )
-import Unique ( Unique{-instances-} )
-import Util ( panic{-ToDo:rm-} )
+import PprType ( pprParendType, pprTyVarBndr )
+
\end{code}
%************************************************************************
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
+Un-annotated core dumps
+~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBinding :: CoreBinding -> SDoc
pprCoreBindings :: [CoreBinding] -> SDoc
+pprCoreBinding :: CoreBinding -> SDoc
+pprCoreExpr :: CoreExpr -> SDoc
-init_ppr_env tvbndr pbdr pocc
- = initPprEnv
- (Just ppr) -- literals
- (Just ppr_con) -- data cons
- (Just ppr_prim) -- primops
- (Just (\ cc -> text (showCostCentre True cc)))
-
- (Just tvbndr) -- tyvar binders
- (Just ppr) -- tyvar occs
- (Just pprParendGenType) -- types
-
- (Just pbdr) (Just pocc) -- value vars
- where
+pprCoreBindings = pprTopBinds pprCoreEnv
+pprCoreBinding = pprTopBind pprCoreEnv
+pprCoreExpr = ppr_expr pprCoreEnv
- ppr_con con = ppr con
+pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
+\end{code}
-{- [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.]
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprIfaceUnfolding :: CoreExpr -> SDoc
+pprIfaceUnfolding = ppr_expr pprIfaceEnv
- 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 '!'
--}
+pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
+\end{code}
- -- 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 '!')
+Generic Core (possibly annotated binders etc)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
+pprGenericBindings = pprTopBinds pprGenericEnv
---------------
-pprCoreBindings binds = vcat (map pprCoreBinding binds)
+pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
+pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
-pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr)
+pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
+pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-pprCoreBinding (Rec binds)
- = vcat [ptext SLIT("Rec {"),
- vcat (map ppr_binding binds),
- ptext SLIT("end Rec }")]
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
+ ppr bind = ppr_bind pprGenericEnv bind
-ppr_binding (binder, expr)
- = sep [pprCoreBinder LetBind binder,
- nest 2 (equals <+> pprCoreExpr expr)]
-\end{code}
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
+ ppr expr = ppr_expr pprGenericEnv expr
-General expression printer
+instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
+ ppr arg = ppr_arg pprGenericArgEnv arg
-\begin{code}
-pprCoreExpr :: CoreExpr -> SDoc
-pprCoreExpr = ppr_expr pprCoreEnv
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
+ ppr alts = ppr_alts pprGenericEnv alts
-pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
+ ppr deflt = ppr_default pprGenericEnv deflt
\end{code}
-Printer for unfoldings in interfaces
-
-\begin{code}
-pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
-
-pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
-\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
-\begin{code}
-pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
-pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr
-pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
-pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
- ppr bind = ppr_bind pprGenEnv bind
+\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)))
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
- ppr expr = ppr_expr pprGenEnv expr
+ (Just tvbndr) -- tyvar binders
+ (Just ppr) -- tyvar occs
+ (Just pprParendType) -- types
-instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
- ppr arg = ppr_arg pprGenArgEnv arg
+ (Just pbdr) (Just pocc) -- value vars
+ where
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
- ppr alts = ppr_alts pprGenEnv alts
+ -- 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 '!')
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
- ppr deflt = ppr_default pprGenEnv deflt
\end{code}
%************************************************************************
%* *
-\subsection{Workhorse routines (...????...)}
+\subsection{The guts}
%* *
%************************************************************************
\begin{code}
+pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
+
+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 pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
ppr_bind pe (Rec binds) = vcat (map pp binds)
where
where
pp_vars lam pp [] = empty
pp_vars lam pp vs
- = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
+ = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
ppr_expr pe expr@(App fun arg)
= let
Rec _ -> SLIT("_letrec_ {")
NonRec _ _ -> SLIT("let {")
-ppr_expr pe (SCC cc expr)
+ppr_expr pe (Note (SCC cc) expr)
= sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
- ppr_parend_expr pe expr ]
-
-ppr_expr pe (Coerce c ty expr)
- = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
- where
- pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v)
- pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
+ ppr_parend_expr pe 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
+ else
+ sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
+ ppr_parend_expr pe expr] sty
+#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]
+#endif
+
+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
= vcat [sig, pragmas, ppr binder]
where
sig = pprTypedBinder binder
- pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
+ pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
pprCoreBinder LambdaBind binder = pprTypedBinder binder
pprCoreBinder CaseBind binder = ppr binder
pprIfaceBinder other binder = pprTypedBinder binder
pprTypedBinder binder
- = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType 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.
--
projects / ghc-hetmet.git / blobdiff