2 % (c) The AQUA Project, Glasgow University, 1996
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
11 #include "HsVersions.h"
14 pprCoreExpr, pprIfaceUnfolding,
15 pprCoreBinding, pprCoreBindings,
19 -- these are here to make the instances go in 0.26:
20 #if __GLASGOW_HASKELL__ <= 30
21 , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
22 , GenCoreCaseDefault, GenCoreArg
29 import CostCentre ( showCostCentre )
30 import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
31 nullIdEnv, SYN_IE(DataCon), GenId{-instances-},
34 import IdInfo ( ppIdInfo, ppStrictnessInfo )
35 import Literal ( Literal{-instances-} )
36 import Name ( OccName )
37 import Outputable -- quite a few things
39 import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
41 import PrimOp ( PrimOp{-instances-} )
42 import TyVar ( GenTyVar{-instances-} )
43 import Unique ( Unique{-instances-} )
44 import Usage ( GenUsage{-instances-} )
45 import Util ( panic{-ToDo:rm-} )
48 %************************************************************************
50 \subsection{Public interfaces for Core printing (excluding instances)}
52 %************************************************************************
54 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
55 function for ``major'' val_bdrs (those next to equal signs :-),
56 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
57 usually be called through some intermediary.
59 The binder/occ printers take the default ``homogenized'' (see
60 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
61 homogenized one, or they can ignore it completely. In other words,
62 the things passed in act as ``hooks'', getting the last word on how to
65 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
68 pprCoreBinding :: PprStyle -> CoreBinding -> Doc
69 pprCoreBindings :: PprStyle -> [CoreBinding] -> Doc
72 :: (Eq tyvar, Outputable tyvar,
73 Eq uvar, Outputable uvar,
77 -> (bndr -> Doc) -- to print "major" val_bdrs
78 -> (bndr -> Doc) -- to print "minor" val_bdrs
79 -> (occ -> Doc) -- to print bindees
80 -> GenCoreBinding bndr occ tyvar uvar
83 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
84 = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
86 init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
88 (Just (ppr sty)) -- literals
89 (Just ppr_con) -- data cons
90 (Just ppr_prim) -- primops
91 (Just (\ cc -> text (showCostCentre sty True cc)))
92 (Just tvbndr) -- tyvar binders
93 (Just (ppr sty)) -- tyvar occs
94 (Just (ppr sty)) -- usage vars
95 (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
96 (Just (pprParendGenType sty)) -- types
97 (Just (ppr sty)) -- usages
100 ppr_con con = ppr sty con
102 {- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
103 [We can't treat them as ordinary applications because the Con doesn't have
104 dictionaries in it, whereas the constructor Id does.]
107 -- ppr_con is used when printing Con expressions; we add a "!"
108 -- to distinguish them from ordinary applications. But not when
109 -- printing for interfaces, where they are treated as ordinary applications
110 ppr_con con | ifaceStyle sty = ppr sty con
111 | otherwise = ppr sty con <> char '!'
114 -- We add a "!" to distinguish Primitive applications from ordinary applications.
115 -- But not when printing for interfaces, where they are treated
116 -- as ordinary applications
117 ppr_prim prim | ifaceStyle sty = ppr sty prim
118 | otherwise = ppr sty prim <> char '!'
121 pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds)
123 pprCoreBinding sty (NonRec binder expr)
124 = hang (hsep [pprBigCoreBinder sty binder, equals])
125 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
127 pprCoreBinding sty (Rec binds)
128 = vcat [ptext SLIT("Rec {"),
129 vcat (map ppr_bind binds),
130 ptext SLIT("end Rec }")]
132 ppr_bind (binder, expr)
133 = hang (hsep [pprBigCoreBinder sty binder, equals])
134 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
140 -> (Id -> Doc) -- to print "major" val_bdrs
141 -> (Id -> Doc) -- to print "minor" val_bdrs
142 -> (Id -> Doc) -- to print bindees
145 pprCoreExpr = pprGenCoreExpr
147 pprGenCoreExpr, pprParendCoreExpr
148 :: (Eq tyvar, Outputable tyvar,
149 Eq uvar, Outputable uvar,
153 -> (bndr -> Doc) -- to print "major" val_bdrs
154 -> (bndr -> Doc) -- to print "minor" val_bdrs
155 -> (occ -> Doc) -- to print bindees
156 -> GenCoreExpr bndr occ tyvar uvar
159 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
160 = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
162 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
166 Var _ -> id -- leave unchanged
168 _ -> parens -- wraps in parens
170 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
172 -- Printer for unfoldings in interfaces
173 pprIfaceUnfolding :: CoreExpr -> Doc
174 pprIfaceUnfolding = ppr_expr env
176 env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
177 (pprTypedCoreBinder PprInterface)
181 ppr_core_arg sty pocc arg
182 = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
184 ppr_core_alts sty pbdr1 pbdr2 pocc alts
185 = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
187 ppr_core_default sty pbdr1 pbdr2 pocc deflt
188 = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
191 %************************************************************************
193 \subsection{Instance declarations for Core printing}
195 %************************************************************************
199 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
200 Eq uvar, Outputable uvar)
202 Outputable (GenCoreBinding bndr occ tyvar uvar) where
203 ppr sty bind = pprQuote sty $ \sty ->
204 pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
207 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
208 Eq uvar, Outputable uvar)
210 Outputable (GenCoreExpr bndr occ tyvar uvar) where
211 ppr sty expr = pprQuote sty $ \sty ->
212 pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
215 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
217 Outputable (GenCoreArg occ tyvar uvar) where
218 ppr sty arg = pprQuote sty $ \sty ->
219 ppr_core_arg sty (ppr sty) arg
222 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
223 Eq uvar, Outputable uvar)
225 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
226 ppr sty alts = pprQuote sty $ \sty ->
227 ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
230 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
231 Eq uvar, Outputable uvar)
233 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
234 ppr sty deflt = pprQuote sty $ \sty ->
235 ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
238 %************************************************************************
240 \subsection{Workhorse routines (...????...)}
242 %************************************************************************
245 ppr_bind pe (NonRec val_bdr expr)
246 = hang (hsep [pMajBndr pe val_bdr, equals])
249 ppr_bind pe (Rec binds)
250 = vcat (map ppr_pair binds)
252 ppr_pair (val_bdr, expr)
253 = hang (hsep [pMajBndr pe val_bdr, equals])
254 4 (ppr_expr pe expr <> semi)
258 ppr_parend_expr pe expr
262 Var _ -> id -- leave unchanged
264 _ -> parens -- wraps in parens
266 parenify (ppr_expr pe expr)
270 ppr_expr pe (Var name) = pOcc pe name
271 ppr_expr pe (Lit lit) = pLit pe lit
273 ppr_expr pe (Con con args)
275 4 (braces $ sep (map (ppr_arg pe) args))
277 ppr_expr pe (Prim prim args)
278 = hang (pPrim pe prim)
279 4 (sep (map (ppr_arg pe) args))
281 ppr_expr pe expr@(Lam _ _)
283 (uvars, tyvars, vars, body) = collectBinders expr
285 hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
286 pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
287 pp_vars SLIT("\\") (pMajBndr pe) vars])
290 pp_vars lam pp [] = empty
292 = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
294 ppr_expr pe expr@(App fun arg)
296 (final_fun, final_args) = go fun [arg]
297 go (App fun arg) args_so_far = go fun (arg:args_so_far)
298 go fun args_so_far = (fun, args_so_far)
300 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
302 ppr_expr pe (Case expr alts)
304 -- johan thinks that single case patterns should be on same line as case,
305 -- and no indent; all sane persons agree with him.
308 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
309 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
310 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
311 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
313 hsep (map (pMinBndr pe) params),
316 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
317 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
318 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
319 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
322 ppr_arrow = ptext SLIT(" ->")
325 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
326 (<>) (ppr_rhs alts) (text ";}")]
328 | otherwise -- default "case" printing
330 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
331 nest 2 (ppr_alts pe alts),
334 pp_keyword = case alts of
335 AlgAlts _ _ -> ptext SLIT("case")
336 PrimAlts _ _ -> ptext SLIT("case#")
338 -- special cases: let ... in let ...
339 -- ("disgusting" SLPJ)
341 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
343 hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals],
344 nest 2 (ppr_expr pe rhs),
348 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
350 (hang (ptext SLIT("let {"))
351 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals])
353 ptext SLIT("} in")]))
356 -- general case (recursive case, too)
357 ppr_expr pe (Let bind expr)
358 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
359 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
361 keyword = case bind of
362 Rec _ -> SLIT("_letrec_ {")
363 NonRec _ _ -> SLIT("let {")
365 ppr_expr pe (SCC cc expr)
366 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
367 ppr_parend_expr pe expr ]
369 ppr_expr pe (Coerce c ty expr)
370 = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
372 pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v)
373 pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
375 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
376 only_one_alt (AlgAlts (_:[]) NoDefault) = True
377 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
378 only_one_alt (PrimAlts (_:[]) NoDefault) = True
379 only_one_alt _ = False
383 ppr_alts pe (AlgAlts alts deflt)
384 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
386 ppr_arrow = ptext SLIT("->")
388 ppr_alt (con, params, expr)
389 = hang (if isTupleCon con then
390 hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))),
394 hsep (map (pMinBndr pe) params),
397 4 (ppr_expr pe expr <> semi)
399 ppr_alts pe (PrimAlts alts deflt)
400 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
403 = hang (hsep [pLit pe lit, ptext SLIT("->")])
404 4 (ppr_expr pe expr <> semi)
408 ppr_default pe NoDefault = empty
410 ppr_default pe (BindDefault val_bdr expr)
411 = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
412 4 (ppr_expr pe expr <> semi)
416 ppr_arg pe (LitArg lit) = pLit pe lit
417 ppr_arg pe (VarArg v) = pOcc pe v
418 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
419 ppr_arg pe (UsageArg use) = pUse pe use
422 Other printing bits-and-bobs used with the general @pprCoreBinding@
423 and @pprCoreExpr@ functions.
426 pprBigCoreBinder sty binder
427 = vcat [sig, pragmas, ppr sty binder]
429 sig = ifnotPprShowAll sty (
430 hsep [ppr sty binder, ppDcolon, ppr sty (idType binder)])
432 {- Having the type come on a separate line does not look "right" to me (doesn't
433 save too much space either), so I've replaced it with a one-line version. -- SOF
435 hang (hsep [ppr sty binder, ppDcolon])
436 4 (ppr sty (idType binder)))
441 (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
443 pprBabyCoreBinder sty binder
444 = hsep [ppr sty binder, pp_strictness]
446 pp_strictness = ppStrictnessInfo sty (getIdStrictness binder)
448 pprTypedCoreBinder sty binder
449 = hcat [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
451 ppDcolon = ptext SLIT(" :: ")
452 -- The space before the :: is important; it helps the lexer
453 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.