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,
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, parenInCode )
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
71 :: (Eq tyvar, Outputable tyvar,
72 Eq uvar, Outputable uvar,
76 -> (bndr -> Doc) -- to print "major" val_bdrs
77 -> (bndr -> Doc) -- to print "minor" val_bdrs
78 -> (occ -> Doc) -- to print bindees
79 -> GenCoreBinding bndr occ tyvar uvar
82 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
83 = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
85 init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
87 (Just (ppr sty)) -- literals
88 (Just ppr_con) -- data cons
89 (Just ppr_prim) -- primops
90 (Just (\ cc -> text (showCostCentre sty True cc)))
91 (Just tvbndr) -- tyvar binders
92 (Just (ppr sty)) -- tyvar occs
93 (Just (ppr sty)) -- usage vars
94 (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
95 (Just (pprParendGenType sty)) -- types
96 (Just (ppr sty)) -- usages
99 ppr_con con = ppr sty con
101 {- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
102 [We can't treat them as ordinary applications because the Con doesn't have
103 dictionaries in it, whereas the constructor Id does.]
106 -- ppr_con is used when printing Con expressions; we add a "!"
107 -- to distinguish them from ordinary applications. But not when
108 -- printing for interfaces, where they are treated as ordinary applications
109 ppr_con con | ifaceStyle sty = ppr sty con
110 | otherwise = ppr sty con <> char '!'
113 -- We add a "!" to distinguish Primitive applications from ordinary applications.
114 -- But not when printing for interfaces, where they are treated
115 -- as ordinary applications
116 ppr_prim prim | ifaceStyle sty = ppr sty prim
117 | otherwise = ppr sty prim <> char '!'
120 pprCoreBinding sty (NonRec binder expr)
121 = hang (hsep [pprBigCoreBinder sty binder, equals])
122 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
124 pprCoreBinding sty (Rec binds)
125 = vcat [ptext SLIT("Rec {"),
126 vcat (map ppr_bind binds),
127 ptext SLIT("end Rec }")]
129 ppr_bind (binder, expr)
130 = hang (hsep [pprBigCoreBinder sty binder, equals])
131 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
137 -> (Id -> Doc) -- to print "major" val_bdrs
138 -> (Id -> Doc) -- to print "minor" val_bdrs
139 -> (Id -> Doc) -- to print bindees
142 pprCoreExpr = pprGenCoreExpr
144 pprGenCoreExpr, pprParendCoreExpr
145 :: (Eq tyvar, Outputable tyvar,
146 Eq uvar, Outputable uvar,
150 -> (bndr -> Doc) -- to print "major" val_bdrs
151 -> (bndr -> Doc) -- to print "minor" val_bdrs
152 -> (occ -> Doc) -- to print bindees
153 -> GenCoreExpr bndr occ tyvar uvar
156 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
157 = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
159 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
163 Var _ -> id -- leave unchanged
165 _ -> parens -- wraps in parens
167 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
169 -- Printer for unfoldings in interfaces
170 pprIfaceUnfolding :: CoreExpr -> Doc
171 pprIfaceUnfolding = ppr_expr env
173 env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
174 (pprTypedCoreBinder PprInterface)
178 ppr_core_arg sty pocc arg
179 = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
181 ppr_core_alts sty pbdr1 pbdr2 pocc alts
182 = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
184 ppr_core_default sty pbdr1 pbdr2 pocc deflt
185 = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
188 %************************************************************************
190 \subsection{Instance declarations for Core printing}
192 %************************************************************************
196 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
197 Eq uvar, Outputable uvar)
199 Outputable (GenCoreBinding bndr occ tyvar uvar) where
200 ppr sty bind = pprQuote sty $ \sty ->
201 pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
204 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
205 Eq uvar, Outputable uvar)
207 Outputable (GenCoreExpr bndr occ tyvar uvar) where
208 ppr sty expr = pprQuote sty $ \sty ->
209 pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
212 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
214 Outputable (GenCoreArg occ tyvar uvar) where
215 ppr sty arg = pprQuote sty $ \sty ->
216 ppr_core_arg sty (ppr sty) arg
219 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
220 Eq uvar, Outputable uvar)
222 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
223 ppr sty alts = pprQuote sty $ \sty ->
224 ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
227 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
228 Eq uvar, Outputable uvar)
230 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
231 ppr sty deflt = pprQuote sty $ \sty ->
232 ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
235 %************************************************************************
237 \subsection{Workhorse routines (...????...)}
239 %************************************************************************
242 ppr_bind pe (NonRec val_bdr expr)
243 = hang (hsep [pMajBndr pe val_bdr, equals])
246 ppr_bind pe (Rec binds)
247 = vcat (map ppr_pair binds)
249 ppr_pair (val_bdr, expr)
250 = hang (hsep [pMajBndr pe val_bdr, equals])
251 4 (ppr_expr pe expr <> semi)
255 ppr_parend_expr pe expr
259 Var _ -> id -- leave unchanged
261 _ -> parens -- wraps in parens
263 parenify (ppr_expr pe expr)
267 ppr_expr pe (Var name) = pOcc pe name
268 ppr_expr pe (Lit lit) = pLit pe lit
270 ppr_expr pe (Con con args)
272 4 (braces $ sep (map (ppr_arg pe) args))
274 ppr_expr pe (Prim prim args)
275 = hang (pPrim pe prim)
276 4 (sep (map (ppr_arg pe) args))
278 ppr_expr pe expr@(Lam _ _)
280 (uvars, tyvars, vars, body) = collectBinders expr
282 hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
283 pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
284 pp_vars SLIT("\\") (pMajBndr pe) vars])
287 pp_vars lam pp [] = empty
289 = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
291 ppr_expr pe expr@(App fun arg)
293 (final_fun, final_args) = go fun [arg]
294 go (App fun arg) args_so_far = go fun (arg:args_so_far)
295 go fun args_so_far = (fun, args_so_far)
297 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
299 ppr_expr pe (Case expr alts)
301 -- johan thinks that single case patterns should be on same line as case,
302 -- and no indent; all sane persons agree with him.
305 ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
306 ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
307 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
308 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
310 hsep (map (pMinBndr pe) params),
313 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
314 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
315 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
316 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
319 ppr_arrow = ptext SLIT(" ->")
322 [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
323 (<>) (ppr_rhs alts) (text ";}")]
325 | otherwise -- default "case" printing
327 [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
328 nest 2 (ppr_alts pe alts),
331 pp_keyword = case alts of
332 AlgAlts _ _ -> ptext SLIT("case")
333 PrimAlts _ _ -> ptext SLIT("case#")
335 -- special cases: let ... in let ...
336 -- ("disgusting" SLPJ)
338 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
340 hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals],
341 nest 2 (ppr_expr pe rhs),
345 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
347 (hang (ptext SLIT("let {"))
348 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals])
350 ptext SLIT("} in")]))
353 -- general case (recursive case, too)
354 ppr_expr pe (Let bind expr)
355 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
356 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
358 keyword = case bind of
359 Rec _ -> SLIT("_letrec_ {")
360 NonRec _ _ -> SLIT("let {")
362 ppr_expr pe (SCC cc expr)
363 = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
364 ppr_parend_expr pe expr ]
366 ppr_expr pe (Coerce c ty expr)
367 = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
369 pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v)
370 pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
372 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
373 only_one_alt (AlgAlts (_:[]) NoDefault) = True
374 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
375 only_one_alt (PrimAlts (_:[]) NoDefault) = True
376 only_one_alt _ = False
380 ppr_alts pe (AlgAlts alts deflt)
381 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
383 ppr_arrow = ptext SLIT("->")
385 ppr_alt (con, params, expr)
386 = hang (if isTupleCon con then
387 hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))),
391 hsep (map (pMinBndr pe) params),
394 4 (ppr_expr pe expr <> semi)
396 ppr_alts pe (PrimAlts alts deflt)
397 = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
400 = hang (hsep [pLit pe lit, ptext SLIT("->")])
401 4 (ppr_expr pe expr <> semi)
405 ppr_default pe NoDefault = empty
407 ppr_default pe (BindDefault val_bdr expr)
408 = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
409 4 (ppr_expr pe expr <> semi)
413 ppr_arg pe (LitArg lit) = pLit pe lit
414 ppr_arg pe (VarArg v) = pOcc pe v
415 ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
416 ppr_arg pe (UsageArg use) = pUse pe use
419 Other printing bits-and-bobs used with the general @pprCoreBinding@
420 and @pprCoreExpr@ functions.
423 pprBigCoreBinder sty binder
424 = vcat [sig, pragmas, ppr sty binder]
426 sig = ifnotPprShowAll sty (
427 hang (hsep [ppr sty binder, ppDcolon])
428 4 (ppr sty (idType binder)))
431 (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
433 pprBabyCoreBinder sty binder
434 = hsep [ppr sty binder, pp_strictness]
436 pp_strictness = ppStrictnessInfo sty (getIdStrictness binder)
438 pprTypedCoreBinder sty binder
439 = hcat [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
441 ppDcolon = ptext SLIT(" :: ")
442 -- The space before the :: is important; it helps the lexer
443 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.