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, getIdStrictness, isTupleCon,
21 nullIdEnv, DataCon, GenId{-instances-},
24 import IdInfo ( ppIdInfo, ppStrictnessInfo )
25 import Literal ( Literal{-instances-} )
26 import Name ( OccName )
27 import Outputable -- quite a few things
29 import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
30 import PrimOp ( PrimOp{-instances-} )
31 import TyVar ( GenTyVar{-instances-} )
32 import Unique ( Unique{-instances-} )
33 import Util ( panic{-ToDo:rm-} )
36 %************************************************************************
38 \subsection{Public interfaces for Core printing (excluding instances)}
40 %************************************************************************
42 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
43 function for ``major'' val_bdrs (those next to equal signs :-),
44 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
45 usually be called through some intermediary.
47 The binder/occ printers take the default ``homogenized'' (see
48 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
49 homogenized one, or they can ignore it completely. In other words,
50 the things passed in act as ``hooks'', getting the last word on how to
53 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
56 pprCoreBinding :: CoreBinding -> SDoc
57 pprCoreBindings :: [CoreBinding] -> SDoc
59 init_ppr_env tvbndr pbdr pocc
61 (Just ppr) -- literals
62 (Just ppr_con) -- data cons
63 (Just ppr_prim) -- primops
64 (Just (\ cc -> text (showCostCentre True cc)))
66 (Just tvbndr) -- tyvar binders
67 (Just ppr) -- tyvar occs
68 (Just pprParendGenType) -- types
70 (Just pbdr) (Just pocc) -- value vars
75 {- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
76 [We can't treat them as ordinary applications because the Con doesn't have
77 dictionaries in it, whereas the constructor Id does.]
80 -- ppr_con is used when printing Con expressions; we add a "!"
81 -- to distinguish them from ordinary applications. But not when
82 -- printing for interfaces, where they are treated as ordinary applications
83 ppr_con con | ifaceStyle sty = ppr sty con
84 | otherwise = ppr sty con <> char '!'
87 -- We add a "!" to distinguish Primitive applications from ordinary applications.
88 -- But not when printing for interfaces, where they are treated
89 -- as ordinary applications
90 ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
96 pprCoreBindings binds = vcat (map pprCoreBinding binds)
98 pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr)
100 pprCoreBinding (Rec binds)
101 = vcat [ptext SLIT("Rec {"),
102 vcat (map ppr_binding binds),
103 ptext SLIT("end Rec }")]
105 ppr_binding (binder, expr)
106 = sep [pprCoreBinder LetBind binder,
107 nest 2 (equals <+> pprCoreExpr expr)]
110 General expression printer
113 pprCoreExpr :: CoreExpr -> SDoc
114 pprCoreExpr = ppr_expr pprCoreEnv
116 pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
119 Printer for unfoldings in interfaces
122 pprIfaceUnfolding :: CoreExpr -> SDoc
123 pprIfaceUnfolding = ppr_expr pprIfaceEnv
125 pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
128 %************************************************************************
130 \subsection{Instance declarations for Core printing}
132 %************************************************************************
135 pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
136 pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr
138 pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
139 pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
141 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
142 ppr bind = ppr_bind pprGenEnv bind
144 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
145 ppr expr = ppr_expr pprGenEnv expr
147 instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
148 ppr arg = ppr_arg pprGenArgEnv arg
150 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
151 ppr alts = ppr_alts pprGenEnv alts
153 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
154 ppr deflt = ppr_default pprGenEnv deflt
157 %************************************************************************
159 \subsection{Workhorse routines (...????...)}
161 %************************************************************************
164 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
165 ppr_bind pe (Rec binds) = vcat (map pp binds)
167 pp bind = ppr_binding_pe pe bind <> semi
169 ppr_binding_pe pe (val_bdr, expr)
170 = sep [pValBndr pe LetBind val_bdr,
171 nest 2 (equals <+> ppr_expr pe expr)]
175 ppr_parend_expr pe expr
179 Var _ -> id -- leave unchanged
181 _ -> parens -- wraps in parens
183 parenify (ppr_expr pe expr)
187 ppr_expr pe (Var name) = pOcc pe name
188 ppr_expr pe (Lit lit) = pLit pe lit
190 ppr_expr pe (Con con args)
191 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
193 ppr_expr pe (Prim prim args)
194 = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
196 ppr_expr pe expr@(Lam _ _)
198 (tyvars, vars, body) = collectBinders expr
200 hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
201 pp_vars SLIT("\\") (pValBndr pe LambdaBind) vars])
204 pp_vars lam pp [] = empty
206 = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
208 ppr_expr pe expr@(App fun arg)
210 (final_fun, final_args) = go fun [arg]
211 go (App fun arg) args_so_far = go fun (arg:args_so_far)
212 go fun args_so_far = (fun, args_so_far)
214 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
216 ppr_expr pe (Case expr alts)
218 -- johan thinks that single case patterns should be on same line as case,
219 -- and no indent; all sane persons agree with him.
221 ppr_bndr = pValBndr pe CaseBind
223 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
224 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
225 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
226 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
228 hsep (map ppr_bndr params),
231 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
232 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
233 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
234 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
237 ppr_arrow = ptext SLIT(" ->")
240 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
241 (<>) (ppr_rhs alts) (text ";}")]
243 | otherwise -- default "case" printing
245 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
246 nest 2 (ppr_alts pe alts),
249 pp_keyword = case alts of
250 AlgAlts _ _ -> ptext SLIT("case")
251 PrimAlts _ _ -> ptext SLIT("case#")
253 -- special cases: let ... in let ...
254 -- ("disgusting" SLPJ)
256 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
258 hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
259 nest 2 (ppr_expr pe rhs),
263 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
265 (hang (ptext SLIT("let {"))
266 2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
268 ptext SLIT("} in")]))
271 -- general case (recursive case, too)
272 ppr_expr pe (Let bind expr)
273 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
274 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
276 keyword = case bind of
277 Rec _ -> SLIT("_letrec_ {")
278 NonRec _ _ -> SLIT("let {")
280 ppr_expr pe (SCC cc expr)
281 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
282 ppr_parend_expr pe expr ]
284 ppr_expr pe (Coerce c ty expr)
285 = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
287 pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v)
288 pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
290 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
291 only_one_alt (AlgAlts (_:[]) NoDefault) = True
292 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
293 only_one_alt (PrimAlts (_:[]) NoDefault) = True
294 only_one_alt _ = False
298 ppr_alts pe (AlgAlts alts deflt)
299 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
301 ppr_arrow = ptext SLIT("->")
302 ppr_bndr = pValBndr pe CaseBind
304 ppr_alt (con, params, expr)
305 = hang (if isTupleCon con then
306 hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
310 hsep (map ppr_bndr params),
313 4 (ppr_expr pe expr <> semi)
315 ppr_alts pe (PrimAlts alts deflt)
316 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
319 = hang (hsep [pLit pe lit, ptext SLIT("->")])
320 4 (ppr_expr pe expr <> semi)
324 ppr_default pe NoDefault = empty
326 ppr_default pe (BindDefault val_bdr expr)
327 = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
328 4 (ppr_expr pe expr <> semi)
332 ppr_arg pe (LitArg lit) = pLit pe lit
333 ppr_arg pe (VarArg v) = pOcc pe v
334 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
337 Other printing bits-and-bobs used with the general @pprCoreBinding@
338 and @pprCoreExpr@ functions.
341 -- Used for printing dump info
342 pprCoreBinder LetBind binder
343 = vcat [sig, pragmas, ppr binder]
345 sig = pprTypedBinder binder
346 pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
348 pprCoreBinder LambdaBind binder = pprTypedBinder binder
349 pprCoreBinder CaseBind binder = ppr binder
352 -- Used for printing interface-file unfoldings
353 pprIfaceBinder CaseBind binder = ppr binder
354 pprIfaceBinder other binder = pprTypedBinder binder
356 pprTypedBinder binder
357 = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType binder)
358 -- The space before the :: is important; it helps the lexer
359 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
361 -- It's important that the type is parenthesised too, at least when
362 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...