%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
%************************************************************************
\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,
+ pprCoreBinding, pprCoreBindings, pprIdBndr,
+ pprCoreBinding, pprCoreBindings, pprCoreAlt,
+ pprCoreRules, pprCoreRule, pprIdCoreRule
) 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 ( 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,
+ cprInfo, ppCprInfo,
+ workerInfo, ppWorkerInfo,
+ tyGenInfo, ppTyGenInfo
+ )
+import DataCon ( dataConTyCon )
+import TyCon ( tupleTyConBoxity, isTupleTyCon )
+import PprType ( pprParendType, pprTyVarBndr )
+import BasicTypes ( tupleParens )
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}
%************************************************************************
@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.]
-
- 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 '!'
--}
-
- -- 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 '!'
-
---------------
-pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds)
-
-pprCoreBinding sty (NonRec binder expr)
- = hang (hsep [pprBigCoreBinder sty binder, equals])
- 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
-
-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)
+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
+pprCoreAlt = ppr_alt pprCoreEnv
+
+pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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_noparend_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}
%************************************************************************
%* *
%************************************************************************
+
\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 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)
+ = 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
- _ -> parens -- 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_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)
- = hang (pCon pe con)
- 4 (braces $ sep (map (ppr_arg pe) args))
+noParens :: SDoc -> SDoc
+noParens pp = pp
+\end{code}
-ppr_expr pe (Prim prim args)
- = hang (pPrim pe prim)
- 4 (sep (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
- hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
- pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
- pp_vars SLIT("\\") (pMajBndr pe) vars])
- 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 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 fun arg)
+ppr_expr add_par pe expr@(Lam _ _)
= 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)
+ (bndrs, body) = collectBinders expr
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 "}"]
+ 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
+ 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 pe) alts))),
+ char '}'
+ ]
where
- pp_keyword = case alts of
- AlgAlts _ _ -> ptext SLIT("case")
- PrimAlts _ _ -> ptext SLIT("case#")
+ ppr_bndr = pBndr pe CaseBind
+
-- 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],
- nest 2 (ppr_expr pe rhs),
+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_expr pe body ]
+ ppr_noparend_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])
- 4 (ppr_expr pe rhs),
- ptext SLIT("} in")]))
- (ppr_expr pe expr)
+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)
- = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
- hang (ptext SLIT("} 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_ {")
+ 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 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 (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)
-
-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 pe (Note InlineCall expr)
+ = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe 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_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 ]
+ppr_expr add_par pe (Note InlineMe expr)
+ = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
+
+ppr_alt pe (con, args, rhs)
+ = hang (ppr_case_pat pe con args) 4 (ppr_noparend_expr pe rhs)
+
+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)
- = hang (hsep [pLit pe lit, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\end{code}
+ ppr_bndr = pBndr pe CaseBind
+ tc = dataConTyCon dc
-\begin{code}
-ppr_default pe NoDefault = empty
+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)
- = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
- 4 (ppr_expr pe expr <> semi)
-\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) = 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 = pprTypedCoreBinder sty binder
+-- Used for printing dump info
+pprCoreBinder LetBind binder
+ = vcat [sig, pragmas, ppr binder]
+ where
+ 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}
-pprBabyCoreBinder sty binder
- = hsep [ppr sty binder, pp_strictness]
+
+\begin{code}
+ppIdInfo :: Id -> IdInfo -> SDoc
+ppIdInfo b info
+ = hsep [
+ ppFlavourInfo (flavourInfo info),
+ ppArityInfo a,
+ ppTyGenInfo g,
+ 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 = ppStrictnessInfo sty (getIdStrictness binder)
+ a = arityInfo info
+ g = tyGenInfo info
+ s = strictnessInfo 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 (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}
projects / ghc-hetmet.git / blobdiff