%************************************************************************
\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
+ pprGenericBindings
) 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 Id ( idType, getIdInfo, isTupleCon,
+ DataCon, GenId{-instances-}, Id
)
import IdInfo ( ppIdInfo, ppStrictnessInfo )
import Literal ( Literal{-instances-} )
-import Name ( OccName )
import Outputable -- quite a few things
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-} )
\end{code}
@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
+pprCoreBindings :: [CoreBinding] -> SDoc
+pprCoreBinding :: CoreBinding -> SDoc
+pprCoreExpr :: CoreExpr -> SDoc
- ppr_con con = ppr sty con
+pprCoreBindings = pprTopBinds pprCoreEnv
+pprCoreBinding = pprTopBind pprCoreEnv
+pprCoreExpr = ppr_expr pprCoreEnv
-{- [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.]
+pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
+\end{code}
- 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 '!'
--}
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprIfaceUnfolding :: CoreExpr -> SDoc
+pprIfaceUnfolding = ppr_expr pprIfaceEnv
- -- 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 '!'
+pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
+\end{code}
---------------
-pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds)
+Generic Core (possibly annotated binders etc)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
+pprGenericBindings = pprTopBinds pprGenericEnv
-pprCoreBinding sty (NonRec binder expr)
- = hang (hsep [pprBigCoreBinder sty binder, equals])
- 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
+pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
+pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
-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)
-\end{code}
+pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
+pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
-\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)
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
+ ppr bind = ppr_bind pprGenericEnv bind
--- 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)
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
+ ppr expr = ppr_expr pprGenericEnv expr
-ppr_core_arg sty pocc arg
- = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
+instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
+ ppr arg = ppr_arg pprGenericArgEnv arg
-ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
+ ppr alts = ppr_alts pprGenericEnv alts
-ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
+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}
-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
+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 pprParendGenType) -- 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{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 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)]
\end{code}
\begin{code}
ppr_expr pe (Lit lit) = pLit pe lit
ppr_expr pe (Con con args)
- = hang (pCon pe con)
- 4 (braces $ sep (map (ppr_arg pe) args))
+ = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = hang (pPrim pe prim)
- 4 (sep (map (ppr_arg pe) args))
+ = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
= let
- (uvars, tyvars, vars, body) = collectBinders expr
+ (tyvars, vars, body) = collectBinders expr
in
- hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
- pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
- pp_vars SLIT("\\") (pMajndr pe) vars])
+ 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
-- 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_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 (pMinBndr pe) params),
+ hsep (map ppr_bndr params),
ppr_arrow]
ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
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 {"), pValBndr 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])
+ 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
4 (ppr_expr pe rhs),
ptext SLIT("} in")]))
(ppr_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 (pStyle pe) v)
- pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
+ pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v)
+ pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
= 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 (pMinBndr pe) params))),
+ hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
ppr_arrow]
else
hsep [pCon pe con,
- hsep (map (pMinBndr pe) params),
+ hsep (map ppr_bndr params),
ppr_arrow]
)
4 (ppr_expr pe expr <> semi)
ppr_default pe NoDefault = empty
ppr_default pe (BindDefault val_bdr expr)
- = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
+ = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
4 (ppr_expr pe expr <> semi)
\end{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
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
\begin{code}
-pprBigCoreBinder sty binder = pprTypedCoreBinder sty binder
-
-pprBabyCoreBinder sty binder
- = hsep [ppr sty binder, pp_strictness]
+-- Used for printing dump info
+pprCoreBinder LetBind binder
+ = vcat [sig, pragmas, ppr binder]
where
- pp_strictness = ppStrictnessInfo sty (getIdStrictness binder)
+ sig = pprTypedBinder binder
+ pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
+
+pprCoreBinder LambdaBind binder = pprTypedBinder binder
+pprCoreBinder CaseBind binder = ppr binder
+
+
+-- Used for printing interface-file unfoldings
+pprIfaceBinder CaseBind binder = ppr binder
+pprIfaceBinder other binder = pprTypedBinder binder
-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.
+pprTypedBinder binder
+ = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (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) -> ...
\end{code}
projects / ghc-hetmet.git / blobdiff