2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprIfaceUnfolding,
13 pprCoreBinding, pprCoreBindings, pprIdBndr
16 #include "HsVersions.h"
19 import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
20 import Var ( isTyVar )
21 import IdInfo ( ppIdInfo )
22 import Const ( Con(..), DataCon )
23 import DataCon ( isTupleCon, isUnboxedTupleCon )
24 import PprType ( pprParendType, pprTyVarBndr )
29 %************************************************************************
31 \subsection{Public interfaces for Core printing (excluding instances)}
33 %************************************************************************
35 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
36 function for ``major'' val_bdrs (those next to equal signs :-),
37 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
38 usually be called through some intermediary.
40 The binder/occ printers take the default ``homogenized'' (see
41 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
42 homogenized one, or they can ignore it completely. In other words,
43 the things passed in act as ``hooks'', getting the last word on how to
46 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
48 Un-annotated core dumps
49 ~~~~~~~~~~~~~~~~~~~~~~~
51 pprCoreBindings :: [CoreBind] -> SDoc
52 pprCoreBinding :: CoreBind -> SDoc
53 pprCoreExpr :: CoreExpr -> SDoc
55 pprCoreBindings = pprTopBinds pprCoreEnv
56 pprCoreBinding = pprTopBind pprCoreEnv
57 pprCoreExpr = ppr_expr pprCoreEnv
59 pprCoreEnv = initCoreEnv pprCoreBinder
62 Printer for unfoldings in interfaces
63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
65 pprIfaceUnfolding :: CoreExpr -> SDoc
66 pprIfaceUnfolding = ppr_expr pprIfaceEnv
68 pprIfaceEnv = initCoreEnv pprIfaceBinder
72 instance Outputable b => Outputable (Bind b) where
73 ppr bind = ppr_bind pprGenericEnv bind
75 instance Outputable b => Outputable (Expr b) where
76 ppr expr = ppr_expr pprGenericEnv expr
78 pprGenericEnv :: Outputable b => PprEnv b
79 pprGenericEnv = initCoreEnv (\site -> ppr)
82 %************************************************************************
84 \subsection{Instance declarations for Core printing}
86 %************************************************************************
92 (Just ppr) -- Constants
93 (Just ppr) -- Cost centres
95 (Just ppr) -- tyvar occs
96 (Just pprParendType) -- types
98 (Just pbdr) (Just pprIdBndr) -- value vars
99 -- The pprIdBndr part here is a temporary debugging aid
100 -- Revert to ppr if it gets tiresome
103 %************************************************************************
105 \subsection{The guts}
107 %************************************************************************
110 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
112 pprTopBind pe (NonRec binder expr)
113 = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
115 pprTopBind pe (Rec binds)
116 = vcat [ptext SLIT("Rec {"),
117 vcat (map (ppr_binding_pe pe) binds),
118 ptext SLIT("end Rec }"),
123 ppr_bind :: PprEnv b -> Bind b -> SDoc
125 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
126 ppr_bind pe (Rec binds) = vcat (map pp binds)
128 pp bind = ppr_binding_pe pe bind <> semi
130 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
131 ppr_binding_pe pe (val_bdr, expr)
132 = sep [pBndr pe LetBind val_bdr,
133 nest 2 (equals <+> ppr_expr pe expr)]
137 ppr_parend_expr pe expr
138 | no_parens = ppr_expr pe expr
139 | otherwise = parens (ppr_expr pe expr)
141 no_parens = case expr of
144 Con (DataCon dc) _ -> isTupleCon dc
149 ppr_expr :: PprEnv b -> Expr b -> SDoc
151 ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd
153 ppr_expr pe (Var name) = pOcc pe name
155 ppr_expr pe (Con con [])
156 = ppr con -- Nullary constructors too
158 ppr_expr pe (Con (DataCon dc) args)
159 -- Drop the type arguments and print in (a,b,c) notation
161 = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
162 | isUnboxedTupleCon dc
164 hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
167 ppr_expr pe (Con con args)
168 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
170 ppr_expr pe expr@(Lam _ _)
172 (bndrs, body) = collectBinders expr
174 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
177 ppr_expr pe expr@(App fun arg)
179 (final_fun, final_args) = go fun [arg]
180 go (App fun arg) args_so_far = go fun (arg:args_so_far)
181 go fun args_so_far = (fun, args_so_far)
183 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
185 ppr_expr pe (Case expr var [(con,args,rhs)])
186 = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
187 hsep [ptext SLIT("of"),
190 ppr_case_pat pe con args
196 ppr_bndr = pBndr pe CaseBind
198 ppr_expr pe (Case expr var alts)
199 = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
200 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
201 nest 4 (sep (punctuate semi (map ppr_alt alts))),
205 ppr_bndr = pBndr pe CaseBind
207 ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
210 -- special cases: let ... in let ...
211 -- ("disgusting" SLPJ)
213 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
215 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
216 nest 2 (ppr_expr pe rhs),
220 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
221 = hang (ptext SLIT("let {"))
222 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
228 -- general case (recursive case, too)
229 ppr_expr pe (Let bind expr)
230 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
231 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
233 keyword = case bind of
234 Rec _ -> SLIT("__letrec {")
235 NonRec _ _ -> SLIT("let {")
237 ppr_expr pe (Note (SCC cc) expr)
238 = sep [hsep [ptext SLIT("__scc"), pSCC pe cc],
239 ppr_parend_expr pe expr ]
242 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
244 if debugStyle sty && not (ifaceStyle sty) then
245 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
246 ppr_parend_expr pe expr] sty
248 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
249 ppr_parend_expr pe expr] sty
251 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
252 = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
253 ppr_parend_expr pe expr]
256 ppr_expr pe (Note InlineCall expr)
257 = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
259 ppr_case_pat pe con@(DataCon dc) args
261 = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
262 | isUnboxedTupleCon dc
263 = hsep [text "(# " <>
264 hsep (punctuate comma (map ppr_bndr args)) <>
268 ppr_bndr = pBndr pe CaseBind
270 ppr_case_pat pe con args
271 = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
273 ppr_bndr = pBndr pe CaseBind
275 ppr_arg pe (Type ty) = ptext SLIT("__a") <+> pTy pe ty
276 ppr_arg pe expr = ppr_parend_expr pe expr
278 arrow = ptext SLIT("->")
281 Other printing bits-and-bobs used with the general @pprCoreBinding@
282 and @pprCoreExpr@ functions.
285 -- Used for printing dump info
286 pprCoreBinder LetBind binder
287 = vcat [sig, pragmas, ppr binder]
289 sig = pprTypedBinder binder
290 pragmas = ppIdInfo (idInfo binder)
292 -- Lambda bound type variables are preceded by "__a"
293 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
295 -- Case bound things don't get a signature or a herald
296 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
298 -- Used for printing interface-file unfoldings
299 pprIfaceBinder CaseBind binder = pprUntypedBinder binder
300 pprIfaceBinder other binder = pprTypedBinder binder
302 pprUntypedBinder binder
303 | isTyVar binder = pprTyVarBndr binder
304 | otherwise = pprIdBndr binder
306 pprTypedBinder binder
307 | isTyVar binder = ptext SLIT("__a") <+> pprTyVarBndr binder
308 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
309 -- The space before the :: is important; it helps the lexer
310 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
312 -- It's important that the type is parenthesised too, at least when
313 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
315 -- When printing any Id binder in debug mode, we print its inline pragma
316 pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))