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-} )
34 %************************************************************************
36 \subsection{Public interfaces for Core printing (excluding instances)}
38 %************************************************************************
40 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
41 function for ``major'' val_bdrs (those next to equal signs :-),
42 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
43 usually be called through some intermediary.
45 The binder/occ printers take the default ``homogenized'' (see
46 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
47 homogenized one, or they can ignore it completely. In other words,
48 the things passed in act as ``hooks'', getting the last word on how to
51 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
53 Un-annotated core dumps
54 ~~~~~~~~~~~~~~~~~~~~~~~
56 pprCoreBindings :: [CoreBinding] -> SDoc
57 pprCoreBinding :: CoreBinding -> SDoc
58 pprCoreExpr :: CoreExpr -> SDoc
60 pprCoreBindings = pprTopBinds pprCoreEnv
61 pprCoreBinding = pprTopBind pprCoreEnv
62 pprCoreExpr = ppr_expr pprCoreEnv
64 pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
67 Printer for unfoldings in interfaces
68 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
70 pprIfaceUnfolding :: CoreExpr -> SDoc
71 pprIfaceUnfolding = ppr_expr pprIfaceEnv
73 pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
76 Generic Core (possibly annotated binders etc)
77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
79 pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
80 pprGenericBindings = pprTopBinds pprGenericEnv
82 pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
83 pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
85 pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
86 pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
88 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
89 ppr bind = ppr_bind pprGenericEnv bind
91 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
92 ppr expr = ppr_expr pprGenericEnv expr
94 instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
95 ppr arg = ppr_arg pprGenericArgEnv arg
97 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
98 ppr alts = ppr_alts pprGenericEnv alts
100 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
101 ppr deflt = ppr_default pprGenericEnv deflt
105 %************************************************************************
107 \subsection{Instance declarations for Core printing}
109 %************************************************************************
113 init_ppr_env tvbndr pbdr pocc
115 (Just ppr) -- literals
116 (Just ppr) -- data cons
117 (Just ppr_prim) -- primops
118 (Just (\ cc -> text (showCostCentre True cc)))
120 (Just tvbndr) -- tyvar binders
121 (Just ppr) -- tyvar occs
122 (Just pprParendType) -- types
124 (Just pbdr) (Just pocc) -- value vars
127 -- We add a "!" to distinguish Primitive applications from ordinary applications.
128 -- But not when printing for interfaces, where they are treated
129 -- as ordinary applications
130 ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
133 ppr prim <> char '!')
137 %************************************************************************
139 \subsection{The guts}
141 %************************************************************************
144 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
146 pprTopBind pe (NonRec binder expr)
147 = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
149 pprTopBind pe (Rec binds)
150 = vcat [ptext SLIT("Rec {"),
151 vcat (map (ppr_binding_pe pe) binds),
152 ptext SLIT("end Rec }"),
157 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
158 ppr_bind pe (Rec binds) = vcat (map pp binds)
160 pp bind = ppr_binding_pe pe bind <> semi
162 ppr_binding_pe pe (val_bdr, expr)
163 = sep [pValBndr pe LetBind val_bdr,
164 nest 2 (equals <+> ppr_expr pe expr)]
168 ppr_parend_expr pe expr
172 Var _ -> id -- leave unchanged
174 _ -> parens -- wraps in parens
176 parenify (ppr_expr pe expr)
180 ppr_expr pe (Var name) = pOcc pe name
181 ppr_expr pe (Lit lit) = pLit pe lit
183 ppr_expr pe (Con con args)
184 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
186 ppr_expr pe (Prim prim args)
187 = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
189 ppr_expr pe expr@(Lam _ _)
191 (tyvars, vars, body) = collectBinders expr
193 hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
194 pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
197 pp_vars lam pp [] = empty
199 = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
201 ppr_expr pe expr@(App fun arg)
203 (final_fun, final_args) = go fun [arg]
204 go (App fun arg) args_so_far = go fun (arg:args_so_far)
205 go fun args_so_far = (fun, args_so_far)
207 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
209 ppr_expr pe (Case expr alts)
211 -- johan thinks that single case patterns should be on same line as case,
212 -- and no indent; all sane persons agree with him.
214 ppr_bndr = pValBndr pe CaseBind
216 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
217 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
218 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
219 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
221 hsep (map ppr_bndr params),
224 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
225 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
226 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
227 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
230 ppr_arrow = ptext SLIT(" ->")
233 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
234 (<>) (ppr_rhs alts) (text ";}")]
236 | otherwise -- default "case" printing
238 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
239 nest 2 (ppr_alts pe alts),
242 pp_keyword = case alts of
243 AlgAlts _ _ -> ptext SLIT("case")
244 PrimAlts _ _ -> ptext SLIT("case#")
246 -- special cases: let ... in let ...
247 -- ("disgusting" SLPJ)
249 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
251 hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
252 nest 2 (ppr_expr pe rhs),
256 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
258 (hang (ptext SLIT("let {"))
259 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
261 ptext SLIT("} in")]))
264 -- general case (recursive case, too)
265 ppr_expr pe (Let bind expr)
266 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
267 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
269 keyword = case bind of
270 Rec _ -> SLIT("_letrec_ {")
271 NonRec _ _ -> SLIT("let {")
273 ppr_expr pe (Note (SCC cc) expr)
274 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
275 ppr_parend_expr pe expr ]
278 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
280 if debugStyle sty && not (ifaceStyle sty) then
281 sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty, pTy pe from_ty],
282 ppr_parend_expr pe expr] sty
284 sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
285 ppr_parend_expr pe expr] sty
287 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
288 = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
289 ppr_parend_expr pe expr]
292 ppr_expr pe (Note InlineCall expr)
293 = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
295 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
296 only_one_alt (AlgAlts (_:[]) NoDefault) = True
297 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
298 only_one_alt (PrimAlts (_:[]) NoDefault) = True
299 only_one_alt _ = False
303 ppr_alts pe (AlgAlts alts deflt)
304 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
306 ppr_arrow = ptext SLIT("->")
307 ppr_bndr = pValBndr pe CaseBind
309 ppr_alt (con, params, expr)
310 = hang (if isTupleCon con then
311 hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
315 hsep (map ppr_bndr params),
318 4 (ppr_expr pe expr <> semi)
320 ppr_alts pe (PrimAlts alts deflt)
321 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
324 = hang (hsep [pLit pe lit, ptext SLIT("->")])
325 4 (ppr_expr pe expr <> semi)
329 ppr_default pe NoDefault = empty
331 ppr_default pe (BindDefault val_bdr expr)
332 = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
333 4 (ppr_expr pe expr <> semi)
337 ppr_arg pe (LitArg lit) = pLit pe lit
338 ppr_arg pe (VarArg v) = pOcc pe v
339 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
342 Other printing bits-and-bobs used with the general @pprCoreBinding@
343 and @pprCoreExpr@ functions.
346 -- Used for printing dump info
347 pprCoreBinder LetBind binder
348 = vcat [sig, pragmas, ppr binder]
350 sig = pprTypedBinder binder
351 pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
353 pprCoreBinder LambdaBind binder = pprTypedBinder binder
354 pprCoreBinder CaseBind binder = ppr binder
357 -- Used for printing interface-file unfoldings
358 pprIfaceBinder CaseBind binder = ppr binder
359 pprIfaceBinder other binder = pprTypedBinder binder
361 pprTypedBinder binder
362 = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
363 -- The space before the :: is important; it helps the lexer
364 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
366 -- It's important that the type is parenthesised too, at least when
367 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...