2 % (c) The AQUA Project, Glasgow University, 1996
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
11 #include "HsVersions.h"
20 -- these are here to make the instances go in 0.26:
21 #if __GLASGOW_HASKELL__ <= 26
22 , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
23 , GenCoreCaseDefault, GenCoreArg
30 import CostCentre ( showCostCentre )
31 import Id ( idType, getIdInfo, getIdStrictness,
32 nullIdEnv, DataCon(..), GenId{-instances-}
34 import IdInfo ( ppIdInfo, StrictnessInfo(..) )
35 import Literal ( Literal{-instances-} )
36 import Outputable -- quite a few things
37 import PprType ( pprType_Internal,
38 GenType{-instances-}, GenTyVar{-instance-}
40 import PprStyle ( PprStyle(..) )
42 import PrimOp ( PrimOp{-instances-} )
43 import TyVar ( GenTyVar{-instances-} )
44 import Unique ( Unique{-instances-} )
45 import Usage ( GenUsage{-instances-} )
46 import Util ( panic{-ToDo:rm-} )
49 %************************************************************************
51 \subsection{Public interfaces for Core printing (excluding instances)}
53 %************************************************************************
55 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
56 function for ``major'' val_bdrs (those next to equal signs :-),
57 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
58 usually be called through some intermediary.
60 The binder/occ printers take the default ``homogenized'' (see
61 @PrintEnv@...) @Pretty@ and the binder/occ. They can either use the
62 homogenized one, or they can ignore it completely. In other words,
63 the things passed in act as ``hooks'', getting the last word on how to
66 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
69 pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
72 :: (Eq tyvar, Outputable tyvar,
73 Eq uvar, Outputable uvar,
77 -> (bndr -> Pretty) -- to print "major" val_bdrs
78 -> (bndr -> Pretty) -- to print "minor" val_bdrs
79 -> (occ -> Pretty) -- to print bindees
80 -> GenCoreBinding bndr occ tyvar uvar
83 pprCoreBinding sty pbdr1 pbdr2 pocc bind
84 = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
86 pprPlainCoreBinding sty (NonRec binder expr)
87 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
88 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
90 pprPlainCoreBinding sty (Rec binds)
91 = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
92 ppAboves (map ppr_bind binds),
93 ifPprDebug sty (ppStr "{- end plain Rec -}")]
95 ppr_bind (binder, expr)
96 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
97 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
101 pprCoreExpr, pprParendCoreExpr
102 :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
106 -> (bndr -> Pretty) -- to print "major" val_bdrs
107 -> (bndr -> Pretty) -- to print "minor" val_bdrs
108 -> (occ -> Pretty) -- to print bindees
109 -> GenCoreExpr bndr occ tyvar uvar
112 pprCoreExpr sty pbdr1 pbdr2 pocc expr
113 = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
115 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
119 Var _ -> id -- leave unchanged
121 _ -> ppParens -- wraps in parens
123 parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
125 ppr_core_arg sty pocc arg
126 = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
128 ppr_core_alts sty pbdr1 pbdr2 pocc alts
129 = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
131 ppr_core_default sty pbdr1 pbdr2 pocc deflt
132 = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
135 %************************************************************************
137 \subsection{Instance declarations for Core printing}
139 %************************************************************************
143 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
144 Eq uvar, Outputable uvar)
146 Outputable (GenCoreBinding bndr occ tyvar uvar) where
147 ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
150 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
151 Eq uvar, Outputable uvar)
153 Outputable (GenCoreExpr bndr occ tyvar uvar) where
154 ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
157 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
159 Outputable (GenCoreArg occ tyvar uvar) where
160 ppr sty arg = ppr_core_arg sty (ppr sty) arg
163 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
164 Eq uvar, Outputable uvar)
166 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
167 ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
170 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
171 Eq uvar, Outputable uvar)
173 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
174 ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
177 %************************************************************************
179 \subsection{Core printing environment (purely local)}
181 %************************************************************************
183 Similar to @VE@ in @PprType@. The ``values'' we print here
184 are locally-defined nested-scope names; callers to @pprCoreBinding@,
185 etc., can override these.
187 For tyvars and uvars, we {\em do} normally use these homogenized
188 names; for values, we {\em don't}. In printing interfaces, though,
189 we use homogenized value names, so that interfaces don't wobble
190 uncontrollably from changing Unique-based names.
193 data PrintEnv tyvar uvar bndr occ
194 = PE (Literal -> Pretty) -- Doing these this way saves
195 (DataCon -> Pretty) -- carrying around a PprStyle
197 (CostCentre -> Pretty)
199 [Pretty] -- Tyvar pretty names
200 (tyvar -> Pretty) -- Tyvar lookup function
201 [Pretty] -- Uvar pretty names
202 (uvar -> Pretty) -- Uvar lookup function
204 (GenType tyvar uvar -> Pretty)
205 (GenUsage uvar -> Pretty)
207 (ValPrinters bndr occ)
209 data ValPrinters bndr occ
210 = BOPE -- print binders/occs differently
211 (bndr -> Pretty) -- to print "major" val_bdrs
212 (bndr -> Pretty) -- to print "minor" val_bdrs
213 (occ -> Pretty) -- to print bindees
215 | VPE -- print all values the same way
216 [Pretty] -- Value pretty names
217 (bndr -> Pretty) -- Binder lookup function
218 (occ -> Pretty) -- Occurrence lookup function
222 initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
223 Outputable bndr, Outputable occ)
226 (bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
228 -> PrintEnv tyvar uvar bndr occ
230 initial_pe sty val_printing
231 = PE (ppr sty) -- for a Literal
232 (ppr sty) -- for a DataCon
233 (ppr sty) -- for a PrimOp
234 (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
236 tv_pretties ppr_tv -- for a TyVar
237 uv_pretties ppr_uv -- for a UsageVar
239 (\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
240 (ppr sty) -- for a Usage
244 ppr_tv = ppr sty -- to print a tyvar
245 ppr_uv = ppr sty -- to print a uvar
247 tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
249 map (\ n -> ppBeside (ppChar 'a') (ppInt n))
250 ([0 .. ] :: [Int]) -- a0 ... aN
252 uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
254 map (\ n -> ppBeside (ppChar 'u') (ppInt n))
255 ([0 .. ] :: [Int]) -- u0 ... uN
257 val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
258 ++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
259 ([0 .. ] :: [Int]) -- v0 ... vN
261 ------------------------
263 = case val_printing of
264 Left (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
265 Right () -> VPE val_pretties (ppr sty) (ppr sty)
270 plit (PE pp _ _ _ _ _ _ _ _ _ _) = pp
271 pcon (PE _ pp _ _ _ _ _ _ _ _ _) = pp
272 pprim (PE _ _ pp _ _ _ _ _ _ _ _) = pp
273 pscc (PE _ _ _ pp _ _ _ _ _ _ _) = pp
274 ptyvar (PE _ _ _ _ _ pp _ _ _ _ _) = pp
275 puvar (PE _ _ _ _ _ _ _ pp _ _ _) = pp
277 pty (PE _ _ _ _ _ _ _ _ pp _ _) = pp
278 puse (PE _ _ _ _ _ _ _ _ _ pp _) = pp
280 pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE pp _ _)) = pp
281 pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
283 pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ pp _)) = pp
284 pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
286 pocc (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ _ pp)) = pp
287 pocc (PE _ _ _ _ _ _ _ _ _ _ (VPE _ _ pp)) = pp
290 %************************************************************************
292 \subsection{Workhorse routines (...????...)}
294 %************************************************************************
297 ppr_bind pe (NonRec val_bdr expr)
298 = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
301 ppr_bind pe (Rec binds)
302 = ppAboves [ ppStr "{- Rec -}",
303 ppAboves (map ppr_pair binds),
304 ppStr "{- end Rec -}" ]
306 ppr_pair (val_bdr, expr)
307 = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
312 ppr_parend_expr pe expr
316 Var _ -> id -- leave unchanged
318 _ -> ppParens -- wraps in parens
320 parenify (ppr_expr pe expr)
324 ppr_expr pe (Var name) = pocc pe name
325 ppr_expr pe (Lit lit) = plit pe lit
326 ppr_expr pe (Con con []) = pcon pe con
328 ppr_expr pe (Con con args)
329 = ppHang (ppBesides [pcon pe con, ppChar '!'])
330 4 (ppSep (map (ppr_arg pe) args))
332 ppr_expr pe (Prim prim args)
333 = ppHang (ppBesides [pprim pe prim, ppChar '!'])
334 4 (ppSep (map (ppr_arg pe) args))
336 ppr_expr pe expr@(Lam _ _)
338 (uvars, tyvars, vars, body) = digForLambdas expr
340 ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars,
341 pp_vars SLIT("_/\\_") (ptyvar pe) tyvars,
342 pp_vars SLIT("\\") (pmin_bdr pe) vars])
345 pp_vars lam pp [] = ppNil
347 = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
349 ppr_expr pe expr@(App _ _)
351 (fun, args) = collectArgs expr
353 ppHang (ppr_parend_expr pe fun)
354 4 (ppSep (map (ppr_arg pe) args))
356 ppr_expr pe (Case expr alts)
358 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
359 ppNest 2 (ppr_alts pe alts),
362 -- special cases: let ... in let ...
363 -- ("disgusting" SLPJ)
365 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
367 ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
368 ppNest 2 (ppr_expr pe rhs),
372 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
374 (ppHang (ppStr "let {")
375 2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
380 -- general case (recursive case, too)
381 ppr_expr pe (Let bind expr)
382 = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
383 ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
385 ppr_expr pe (SCC cc expr)
386 = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
387 ppr_parend_expr pe expr ]
391 ppr_alts pe (AlgAlts alts deflt)
392 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
394 ppr_alt (con, params, expr)
395 = ppHang (ppCat [ppr_con con (pcon pe con),
396 ppInterleave ppSP (map (pmin_bdr pe) params),
401 = if isOpLexeme con then ppParens pp_con else pp_con
403 ppr_alts pe (PrimAlts alts deflt)
404 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
407 = ppHang (ppCat [plit pe lit, ppStr "->"])
412 ppr_default pe NoDefault = ppNil
414 ppr_default pe (BindDefault val_bdr expr)
415 = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
420 ppr_arg pe (LitArg lit) = plit pe lit
421 ppr_arg pe (VarArg v) = pocc pe v
422 ppr_arg pe (TyArg ty) = pty pe ty
423 ppr_arg pe (UsageArg use) = puse pe use
426 Other printing bits-and-bobs used with the general @pprCoreBinding@
427 and @pprCoreExpr@ functions.
430 pprBigCoreBinder sty binder
431 = ppAboves [sig, pragmas, ppr sty binder]
433 sig = ifnotPprShowAll sty (
434 ppHang (ppCat [ppr sty binder, ppStr "::"])
435 4 (ppr sty (idType binder)))
439 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
442 pprBabyCoreBinder sty binder
443 = ppCat [ppr sty binder, pp_strictness]
446 = case (getIdStrictness binder) of
447 NoStrictnessInfo -> ppNil
448 BottomGuaranteed -> ppStr "{- _!_ -}"
449 StrictnessInfo xx _ ->
450 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
451 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
453 pprTypedCoreBinder sty binder
454 = ppBesides [ppLparen, ppCat [ppr sty binder,
455 ppStr "::", ppr sty (idType binder)],