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
16 #include "HsVersions.h"
19 import CostCentre ( showCostCentre )
20 import Id ( idType, getIdInfo, isTupleCon,
21 DataCon, GenId{-instances-}, Id
23 import IdInfo ( ppIdInfo, ppStrictnessInfo )
24 import Literal ( Literal{-instances-} )
25 import Outputable -- quite a few things
27 import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
28 import PrimOp ( PrimOp{-instances-} )
29 import TyVar ( GenTyVar{-instances-} )
30 import Unique ( Unique{-instances-} )
31 import Util ( panic{-ToDo:rm-} )
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.
54 pprCoreBinding :: CoreBinding -> SDoc
55 pprCoreBindings :: [CoreBinding] -> SDoc
57 init_ppr_env tvbndr pbdr pocc
59 (Just ppr) -- literals
60 (Just ppr_con) -- data cons
61 (Just ppr_prim) -- primops
62 (Just (\ cc -> text (showCostCentre True cc)))
64 (Just tvbndr) -- tyvar binders
65 (Just ppr) -- tyvar occs
66 (Just pprParendGenType) -- types
68 (Just pbdr) (Just pocc) -- value vars
73 {- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
74 [We can't treat them as ordinary applications because the Con doesn't have
75 dictionaries in it, whereas the constructor Id does.]
78 -- ppr_con is used when printing Con expressions; we add a "!"
79 -- to distinguish them from ordinary applications. But not when
80 -- printing for interfaces, where they are treated as ordinary applications
81 ppr_con con | ifaceStyle sty = ppr sty con
82 | otherwise = ppr sty con <> char '!'
85 -- We add a "!" to distinguish Primitive applications from ordinary applications.
86 -- But not when printing for interfaces, where they are treated
87 -- as ordinary applications
88 ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
94 pprCoreBindings binds = vcat (map pprCoreBinding binds)
96 pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr)
98 pprCoreBinding (Rec binds)
99 = vcat [ptext SLIT("Rec {"),
100 vcat (map ppr_binding binds),
101 ptext SLIT("end Rec }")]
103 ppr_binding (binder, expr)
104 = sep [pprCoreBinder LetBind binder,
105 nest 2 (equals <+> pprCoreExpr expr)]
108 General expression printer
111 pprCoreExpr :: CoreExpr -> SDoc
112 pprCoreExpr = ppr_expr pprCoreEnv
114 pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
117 Printer for unfoldings in interfaces
120 pprIfaceUnfolding :: CoreExpr -> SDoc
121 pprIfaceUnfolding = ppr_expr pprIfaceEnv
123 pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
126 %************************************************************************
128 \subsection{Instance declarations for Core printing}
130 %************************************************************************
133 pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
134 pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr
136 pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
137 pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
139 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
140 ppr bind = ppr_bind pprGenEnv bind
142 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
143 ppr expr = ppr_expr pprGenEnv expr
145 instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
146 ppr arg = ppr_arg pprGenArgEnv arg
148 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
149 ppr alts = ppr_alts pprGenEnv alts
151 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
152 ppr deflt = ppr_default pprGenEnv deflt
155 %************************************************************************
157 \subsection{Workhorse routines (...????...)}
159 %************************************************************************
162 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
163 ppr_bind pe (Rec binds) = vcat (map pp binds)
165 pp bind = ppr_binding_pe pe bind <> semi
167 ppr_binding_pe pe (val_bdr, expr)
168 = sep [pValBndr pe LetBind val_bdr,
169 nest 2 (equals <+> ppr_expr pe expr)]
173 ppr_parend_expr pe expr
177 Var _ -> id -- leave unchanged
179 _ -> parens -- wraps in parens
181 parenify (ppr_expr pe expr)
185 ppr_expr pe (Var name) = pOcc pe name
186 ppr_expr pe (Lit lit) = pLit pe lit
188 ppr_expr pe (Con con args)
189 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
191 ppr_expr pe (Prim prim args)
192 = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
194 ppr_expr pe expr@(Lam _ _)
196 (tyvars, vars, body) = collectBinders expr
198 hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
199 pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
202 pp_vars lam pp [] = empty
204 = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
206 ppr_expr pe expr@(App fun arg)
208 (final_fun, final_args) = go fun [arg]
209 go (App fun arg) args_so_far = go fun (arg:args_so_far)
210 go fun args_so_far = (fun, args_so_far)
212 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
214 ppr_expr pe (Case expr alts)
216 -- johan thinks that single case patterns should be on same line as case,
217 -- and no indent; all sane persons agree with him.
219 ppr_bndr = pValBndr pe CaseBind
221 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
222 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
223 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
224 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
226 hsep (map ppr_bndr params),
229 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
230 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
231 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
232 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
235 ppr_arrow = ptext SLIT(" ->")
238 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
239 (<>) (ppr_rhs alts) (text ";}")]
241 | otherwise -- default "case" printing
243 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
244 nest 2 (ppr_alts pe alts),
247 pp_keyword = case alts of
248 AlgAlts _ _ -> ptext SLIT("case")
249 PrimAlts _ _ -> ptext SLIT("case#")
251 -- special cases: let ... in let ...
252 -- ("disgusting" SLPJ)
254 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
256 hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
257 nest 2 (ppr_expr pe rhs),
261 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
263 (hang (ptext SLIT("let {"))
264 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
266 ptext SLIT("} in")]))
269 -- general case (recursive case, too)
270 ppr_expr pe (Let bind expr)
271 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
272 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
274 keyword = case bind of
275 Rec _ -> SLIT("_letrec_ {")
276 NonRec _ _ -> SLIT("let {")
278 ppr_expr pe (SCC cc expr)
279 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
280 ppr_parend_expr pe expr ]
282 ppr_expr pe (Coerce c ty expr)
283 = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
285 pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v)
286 pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
288 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
289 only_one_alt (AlgAlts (_:[]) NoDefault) = True
290 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
291 only_one_alt (PrimAlts (_:[]) NoDefault) = True
292 only_one_alt _ = False
296 ppr_alts pe (AlgAlts alts deflt)
297 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
299 ppr_arrow = ptext SLIT("->")
300 ppr_bndr = pValBndr pe CaseBind
302 ppr_alt (con, params, expr)
303 = hang (if isTupleCon con then
304 hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
308 hsep (map ppr_bndr params),
311 4 (ppr_expr pe expr <> semi)
313 ppr_alts pe (PrimAlts alts deflt)
314 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
317 = hang (hsep [pLit pe lit, ptext SLIT("->")])
318 4 (ppr_expr pe expr <> semi)
322 ppr_default pe NoDefault = empty
324 ppr_default pe (BindDefault val_bdr expr)
325 = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
326 4 (ppr_expr pe expr <> semi)
330 ppr_arg pe (LitArg lit) = pLit pe lit
331 ppr_arg pe (VarArg v) = pOcc pe v
332 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
335 Other printing bits-and-bobs used with the general @pprCoreBinding@
336 and @pprCoreExpr@ functions.
339 -- Used for printing dump info
340 pprCoreBinder LetBind binder
341 = vcat [sig, pragmas, ppr binder]
343 sig = pprTypedBinder binder
344 pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
346 pprCoreBinder LambdaBind binder = pprTypedBinder binder
347 pprCoreBinder CaseBind binder = ppr binder
350 -- Used for printing interface-file unfoldings
351 pprIfaceBinder CaseBind binder = ppr binder
352 pprIfaceBinder other binder = pprTypedBinder binder
354 pprTypedBinder binder
355 = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType binder)
356 -- The space before the :: is important; it helps the lexer
357 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
359 -- It's important that the type is parenthesised too, at least when
360 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...