2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprParendExpr,
13 pprCoreBinding, pprCoreBindings, pprIdBndr,
14 pprCoreBinding, pprCoreBindings,
15 pprCoreRules, pprCoreRule
18 #include "HsVersions.h"
21 import CostCentre ( pprCostCentreCore )
22 import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
23 idInfo, idInlinePragma, idDemandInfo, idOccInfo
25 import Var ( isTyVar )
26 import IdInfo ( IdInfo, megaSeqIdInfo, occInfo,
27 arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
28 demandInfo, updateInfo, ppUpdateInfo, specInfo,
29 strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
30 cprInfo, ppCprInfo, lbvarInfo,
31 workerInfo, ppWorkerInfo
33 import DataCon ( dataConTyCon )
34 import TyCon ( tupleTyConBoxity, isTupleTyCon )
35 import PprType ( pprParendType, pprTyVarBndr )
36 import BasicTypes ( tupleParens )
41 %************************************************************************
43 \subsection{Public interfaces for Core printing (excluding instances)}
45 %************************************************************************
47 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
48 function for ``major'' val_bdrs (those next to equal signs :-),
49 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
50 usually be called through some intermediary.
52 The binder/occ printers take the default ``homogenized'' (see
53 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
54 homogenized one, or they can ignore it completely. In other words,
55 the things passed in act as ``hooks'', getting the last word on how to
58 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
60 Un-annotated core dumps
61 ~~~~~~~~~~~~~~~~~~~~~~~
63 pprCoreBindings :: [CoreBind] -> SDoc
64 pprCoreBinding :: CoreBind -> SDoc
65 pprCoreExpr :: CoreExpr -> SDoc
66 pprParendExpr :: CoreExpr -> SDoc
68 pprCoreBindings = pprTopBinds pprCoreEnv
69 pprCoreBinding = pprTopBind pprCoreEnv
70 pprCoreExpr = ppr_noparend_expr pprCoreEnv
71 pprParendExpr = ppr_parend_expr pprCoreEnv
72 pprArg = ppr_arg pprCoreEnv
74 pprCoreEnv = initCoreEnv pprCoreBinder
77 Printer for unfoldings in interfaces
78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80 instance Outputable b => Outputable (Bind b) where
81 ppr bind = ppr_bind pprGenericEnv bind
83 instance Outputable b => Outputable (Expr b) where
84 ppr expr = ppr_noparend_expr pprGenericEnv expr
86 pprGenericEnv :: Outputable b => PprEnv b
87 pprGenericEnv = initCoreEnv (\site -> ppr)
90 %************************************************************************
92 \subsection{Instance declarations for Core printing}
94 %************************************************************************
100 (Just pprCostCentreCore) -- Cost centres
102 (Just ppr) -- tyvar occs
103 (Just pprParendType) -- types
105 (Just pbdr) (Just ppr) -- value vars
106 -- Use pprIdBndr for this last one as a debugging device.
109 %************************************************************************
111 \subsection{The guts}
113 %************************************************************************
116 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
118 pprTopBind pe (NonRec binder expr)
119 = ppr_binding_pe pe (binder,expr) $$ text ""
121 pprTopBind pe (Rec binds)
122 = vcat [ptext SLIT("Rec {"),
123 vcat (map (ppr_binding_pe pe) binds),
124 ptext SLIT("end Rec }"),
129 ppr_bind :: PprEnv b -> Bind b -> SDoc
131 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
132 ppr_bind pe (Rec binds) = vcat (map pp binds)
134 pp bind = ppr_binding_pe pe bind <> semi
136 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
137 ppr_binding_pe pe (val_bdr, expr)
138 = sep [pBndr pe LetBind val_bdr,
139 nest 2 (equals <+> ppr_noparend_expr pe expr)]
143 ppr_parend_expr pe expr = ppr_expr parens pe expr
144 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
146 noParens :: SDoc -> SDoc
151 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
152 -- The function adds parens in context that need
153 -- an atomic value (e.g. function args)
155 ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
157 ppr_expr add_par pe (Var name) = pOcc pe name
158 ppr_expr add_par pe (Lit lit) = ppr lit
160 ppr_expr add_par pe expr@(Lam _ _)
162 (bndrs, body) = collectBinders expr
165 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
166 4 (ppr_noparend_expr pe body)
168 ppr_expr add_par pe expr@(App fun arg)
169 = case collectArgs expr of { (fun, args) ->
171 pp_args = sep (map (ppr_arg pe) args)
172 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
173 pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
176 Var f -> case isDataConId_maybe f of
177 -- Notice that we print the *worker*
178 -- for tuples in paren'd format.
179 Just dc | saturated && isTupleTyCon tc
180 -> tupleParens (tupleTyConBoxity tc) pp_tup_args
183 saturated = length val_args == idArity f
185 other -> add_par (hang (pOcc pe f) 4 pp_args)
187 other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
190 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
192 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
193 hsep [ptext SLIT("of"),
196 ppr_case_pat pe con args
198 ppr_noparend_expr pe rhs,
202 ppr_bndr = pBndr pe CaseBind
204 ppr_expr add_par pe (Case expr var alts)
206 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
207 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
208 nest 4 (sep (punctuate semi (map ppr_alt alts))),
212 ppr_bndr = pBndr pe CaseBind
214 ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
215 4 (ppr_noparend_expr pe rhs)
217 -- special cases: let ... in let ...
218 -- ("disgusting" SLPJ)
220 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
223 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
224 nest 2 (ppr_noparend_expr pe rhs),
226 ppr_noparend_expr pe body ]
228 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
230 (hang (ptext SLIT("let {"))
231 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
232 4 (ppr_noparend_expr pe rhs),
235 ppr_noparend_expr pe expr)
237 -- general case (recursive case, too)
238 ppr_expr add_par pe (Let bind expr)
240 sep [hang (ptext keyword) 2 (ppr_bind pe bind),
241 hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
243 keyword = case bind of
244 Rec _ -> SLIT("__letrec {")
245 NonRec _ _ -> SLIT("let {")
247 ppr_expr add_par pe (Note (SCC cc) expr)
248 = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
251 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
253 getPprStyle $ \ sty ->
254 if debugStyle sty && not (ifaceStyle sty) then
255 sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
256 ppr_parend_expr pe expr]
258 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
259 ppr_parend_expr pe expr]
261 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
263 sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
264 ppr_parend_expr pe expr]
267 ppr_expr add_par pe (Note InlineCall expr)
268 = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
270 ppr_expr add_par pe (Note InlineMe expr)
271 = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
273 ppr_expr add_par pe (Note (TermUsg u) expr)
274 = getPprStyle $ \ sty ->
275 if ifaceStyle sty then
276 ppr_expr add_par pe expr
278 add_par (ppr u <+> ppr_noparend_expr pe expr)
280 ppr_case_pat pe con@(DataAlt dc) args
282 = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
284 ppr_bndr = pBndr pe CaseBind
287 ppr_case_pat pe con args
288 = ppr con <+> hsep (map ppr_bndr args) <+> arrow
290 ppr_bndr = pBndr pe CaseBind
292 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
293 ppr_arg pe expr = ppr_parend_expr pe expr
295 arrow = ptext SLIT("->")
298 Other printing bits-and-bobs used with the general @pprCoreBinding@
299 and @pprCoreExpr@ functions.
302 -- Used for printing dump info
303 pprCoreBinder LetBind binder
304 = vcat [sig, pragmas, ppr binder]
306 sig = pprTypedBinder binder
307 pragmas = ppIdInfo binder (idInfo binder)
309 -- Lambda bound type variables are preceded by "@"
310 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
312 -- Case bound things don't get a signature or a herald
313 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
315 pprUntypedBinder binder
316 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
317 | otherwise = pprIdBndr binder
319 pprTypedBinder binder
320 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
321 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
322 -- The space before the :: is important; it helps the lexer
323 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
325 -- It's important that the type is parenthesised too, at least when
326 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
328 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
329 pprIdBndr id = ppr id <+>
330 (megaSeqIdInfo (idInfo id) `seq`
331 -- Useful for poking on black holes
332 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
333 ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
338 ppIdInfo :: Id -> IdInfo -> SDoc
341 ppFlavourInfo (flavourInfo info),
344 ppWorkerInfo (workerInfo info),
349 -- Inline pragma, occ, demand, lbvar info
350 -- printed out with all binders (when debug is on);
351 -- see PprCore.pprIdBndr
355 s = strictnessInfo info
364 pprCoreRules :: Id -> CoreRules -> SDoc
365 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
367 pprCoreRule :: SDoc -> CoreRule -> SDoc
368 pprCoreRule pp_fn (BuiltinRule _)
369 = ifPprDebug (ptext SLIT("A built in rule"))
371 pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
372 = doubleQuotes (ptext name) <+>
374 ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
375 nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
376 nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)