2 % (c) The AQUA Project, Glasgow University, 1996
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprIfaceUnfolding,
13 pprCoreBinding, pprCoreBindings,
17 #include "HsVersions.h"
20 import CostCentre ( showCostCentre )
21 import Id ( idType, idInfo, isTupleCon,
22 DataCon, GenId{-instances-}, Id
24 import IdInfo ( ppIdInfo, ppStrictnessInfo )
25 import Literal ( Literal{-instances-} )
26 import Outputable -- quite a few things
28 import PprType ( pprParendType, pprTyVarBndr )
29 import PrimOp ( PrimOp{-instances-} )
30 import TyVar ( GenTyVar{-instances-} )
31 import Unique ( Unique{-instances-} )
32 import Util ( panic{-ToDo:rm-} )
35 %************************************************************************
37 \subsection{Public interfaces for Core printing (excluding instances)}
39 %************************************************************************
41 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
42 function for ``major'' val_bdrs (those next to equal signs :-),
43 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
44 usually be called through some intermediary.
46 The binder/occ printers take the default ``homogenized'' (see
47 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
48 homogenized one, or they can ignore it completely. In other words,
49 the things passed in act as ``hooks'', getting the last word on how to
52 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
54 Un-annotated core dumps
55 ~~~~~~~~~~~~~~~~~~~~~~~
57 pprCoreBindings :: [CoreBinding] -> SDoc
58 pprCoreBinding :: CoreBinding -> SDoc
59 pprCoreExpr :: CoreExpr -> SDoc
61 pprCoreBindings = pprTopBinds pprCoreEnv
62 pprCoreBinding = pprTopBind pprCoreEnv
63 pprCoreExpr = ppr_expr pprCoreEnv
65 pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
68 Printer for unfoldings in interfaces
69 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
71 pprIfaceUnfolding :: CoreExpr -> SDoc
72 pprIfaceUnfolding = ppr_expr pprIfaceEnv
74 pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
77 Generic Core (possibly annotated binders etc)
78 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80 pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
81 pprGenericBindings = pprTopBinds pprGenericEnv
83 pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
84 pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
86 pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
87 pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
89 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
90 ppr bind = ppr_bind pprGenericEnv bind
92 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
93 ppr expr = ppr_expr pprGenericEnv expr
95 instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
96 ppr arg = ppr_arg pprGenericArgEnv arg
98 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
99 ppr alts = ppr_alts pprGenericEnv alts
101 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
102 ppr deflt = ppr_default pprGenericEnv deflt
106 %************************************************************************
108 \subsection{Instance declarations for Core printing}
110 %************************************************************************
114 init_ppr_env tvbndr pbdr pocc
116 (Just ppr) -- literals
117 (Just ppr) -- data cons
118 (Just ppr_prim) -- primops
119 (Just (\ cc -> text (showCostCentre True cc)))
121 (Just tvbndr) -- tyvar binders
122 (Just ppr) -- tyvar occs
123 (Just pprParendType) -- types
125 (Just pbdr) (Just pocc) -- value vars
128 -- We add a "!" to distinguish Primitive applications from ordinary applications.
129 -- But not when printing for interfaces, where they are treated
130 -- as ordinary applications
131 ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
134 ppr prim <> char '!')
138 %************************************************************************
140 \subsection{The guts}
142 %************************************************************************
145 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
147 pprTopBind pe (NonRec binder expr)
148 = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
150 pprTopBind pe (Rec binds)
151 = vcat [ptext SLIT("Rec {"),
152 vcat (map (ppr_binding_pe pe) binds),
153 ptext SLIT("end Rec }"),
158 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
159 ppr_bind pe (Rec binds) = vcat (map pp binds)
161 pp bind = ppr_binding_pe pe bind <> semi
163 ppr_binding_pe pe (val_bdr, expr)
164 = sep [pValBndr pe LetBind val_bdr,
165 nest 2 (equals <+> ppr_expr pe expr)]
169 ppr_parend_expr pe expr
173 Var _ -> id -- leave unchanged
175 _ -> parens -- wraps in parens
177 parenify (ppr_expr pe expr)
181 ppr_expr pe (Var name) = pOcc pe name
182 ppr_expr pe (Lit lit) = pLit pe lit
184 ppr_expr pe (Con con args)
185 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
187 ppr_expr pe (Prim prim args)
188 = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
190 ppr_expr pe expr@(Lam _ _)
192 (tyvars, vars, body) = collectBinders expr
194 hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
195 pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
198 pp_vars lam pp [] = empty
200 = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
202 ppr_expr pe expr@(App fun arg)
204 (final_fun, final_args) = go fun [arg]
205 go (App fun arg) args_so_far = go fun (arg:args_so_far)
206 go fun args_so_far = (fun, args_so_far)
208 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
210 ppr_expr pe (Case expr alts)
212 -- johan thinks that single case patterns should be on same line as case,
213 -- and no indent; all sane persons agree with him.
215 ppr_bndr = pValBndr pe CaseBind
217 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
218 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
219 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
220 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
222 hsep (map ppr_bndr params),
225 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
226 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
227 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
228 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
231 ppr_arrow = ptext SLIT(" ->")
234 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
235 (<>) (ppr_rhs alts) (text ";}")]
237 | otherwise -- default "case" printing
239 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
240 nest 2 (ppr_alts pe alts),
243 pp_keyword = case alts of
244 AlgAlts _ _ -> ptext SLIT("case")
245 PrimAlts _ _ -> ptext SLIT("case#")
247 -- special cases: let ... in let ...
248 -- ("disgusting" SLPJ)
250 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
252 hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
253 nest 2 (ppr_expr pe rhs),
257 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
259 (hang (ptext SLIT("let {"))
260 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
262 ptext SLIT("} in")]))
265 -- general case (recursive case, too)
266 ppr_expr pe (Let bind expr)
267 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
268 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
270 keyword = case bind of
271 Rec _ -> SLIT("_letrec_ {")
272 NonRec _ _ -> SLIT("let {")
274 ppr_expr pe (Note (SCC cc) expr)
275 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
276 ppr_parend_expr pe expr ]
278 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
279 = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
280 ppr_parend_expr pe expr]
282 ppr_expr pe (Note InlineCall expr)
283 = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
285 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
286 only_one_alt (AlgAlts (_:[]) NoDefault) = True
287 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
288 only_one_alt (PrimAlts (_:[]) NoDefault) = True
289 only_one_alt _ = False
293 ppr_alts pe (AlgAlts alts deflt)
294 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
296 ppr_arrow = ptext SLIT("->")
297 ppr_bndr = pValBndr pe CaseBind
299 ppr_alt (con, params, expr)
300 = hang (if isTupleCon con then
301 hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
305 hsep (map ppr_bndr params),
308 4 (ppr_expr pe expr <> semi)
310 ppr_alts pe (PrimAlts alts deflt)
311 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
314 = hang (hsep [pLit pe lit, ptext SLIT("->")])
315 4 (ppr_expr pe expr <> semi)
319 ppr_default pe NoDefault = empty
321 ppr_default pe (BindDefault val_bdr expr)
322 = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
323 4 (ppr_expr pe expr <> semi)
327 ppr_arg pe (LitArg lit) = pLit pe lit
328 ppr_arg pe (VarArg v) = pOcc pe v
329 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
332 Other printing bits-and-bobs used with the general @pprCoreBinding@
333 and @pprCoreExpr@ functions.
336 -- Used for printing dump info
337 pprCoreBinder LetBind binder
338 = vcat [sig, pragmas, ppr binder]
340 sig = pprTypedBinder binder
341 pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
343 pprCoreBinder LambdaBind binder = pprTypedBinder binder
344 pprCoreBinder CaseBind binder = ppr binder
347 -- Used for printing interface-file unfoldings
348 pprIfaceBinder CaseBind binder = ppr binder
349 pprIfaceBinder other binder = pprTypedBinder binder
351 pprTypedBinder binder
352 = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
353 -- The space before the :: is important; it helps the lexer
354 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
356 -- It's important that the type is parenthesised too, at least when
357 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...