2 % (c) The AQUA Project, Glasgow University, 1996
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
11 #include "HsVersions.h"
19 -- these are here to make the instances go in 0.26:
20 #if __GLASGOW_HASKELL__ <= 26
21 , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
22 , GenCoreCaseDefault, GenCoreArg
29 import CostCentre ( showCostCentre )
30 import Id ( idType, getIdInfo, getIdStrictness,
31 nullIdEnv, DataCon(..), GenId{-instances-}
33 import IdInfo ( ppIdInfo, StrictnessInfo(..) )
34 import Literal ( Literal{-instances-} )
35 import Outputable -- quite a few things
37 import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
38 import PprStyle ( PprStyle(..) )
40 import PrimOp ( PrimOp{-instances-} )
41 import TyVar ( GenTyVar{-instances-} )
42 import Unique ( Unique{-instances-} )
43 import Usage ( GenUsage{-instances-} )
44 import Util ( panic{-ToDo:rm-} )
47 %************************************************************************
49 \subsection{Public interfaces for Core printing (excluding instances)}
51 %************************************************************************
53 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
54 function for ``major'' val_bdrs (those next to equal signs :-),
55 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
56 usually be called through some intermediary.
58 The binder/occ printers take the default ``homogenized'' (see
59 @PprEnv@...) @Pretty@ and the binder/occ. They can either use the
60 homogenized one, or they can ignore it completely. In other words,
61 the things passed in act as ``hooks'', getting the last word on how to
64 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
67 pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
70 :: (Eq tyvar, Outputable tyvar,
71 Eq uvar, Outputable uvar,
75 -> (bndr -> Pretty) -- to print "major" val_bdrs
76 -> (bndr -> Pretty) -- to print "minor" val_bdrs
77 -> (occ -> Pretty) -- to print bindees
78 -> GenCoreBinding bndr occ tyvar uvar
81 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
82 = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
84 init_ppr_env sty pbdr1 pbdr2 pocc
86 (Just (ppr sty)) -- literals
87 (Just (ppr sty)) -- data cons
88 (Just (ppr sty)) -- primops
89 (Just (\ cc -> ppStr (showCostCentre sty True cc)))
90 (Just (ppr sty)) -- tyvars
91 (Just (ppr sty)) -- usage vars
92 (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
93 (Just (ppr sty)) -- types
94 (Just (ppr sty)) -- usages
97 pprCoreBinding sty (NonRec binder expr)
98 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
99 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
101 pprCoreBinding sty (Rec binds)
102 = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
103 ppAboves (map ppr_bind binds),
104 ifPprDebug sty (ppStr "{- end plain Rec -}")]
106 ppr_bind (binder, expr)
107 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
108 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
114 -> (Id -> Pretty) -- to print "major" val_bdrs
115 -> (Id -> Pretty) -- to print "minor" val_bdrs
116 -> (Id -> Pretty) -- to print bindees
119 pprCoreExpr = pprGenCoreExpr
121 pprGenCoreExpr, pprParendCoreExpr
122 :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
126 -> (bndr -> Pretty) -- to print "major" val_bdrs
127 -> (bndr -> Pretty) -- to print "minor" val_bdrs
128 -> (occ -> Pretty) -- to print bindees
129 -> GenCoreExpr bndr occ tyvar uvar
132 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
133 = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
135 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
139 Var _ -> id -- leave unchanged
141 _ -> ppParens -- wraps in parens
143 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
145 ppr_core_arg sty pocc arg
146 = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
148 ppr_core_alts sty pbdr1 pbdr2 pocc alts
149 = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
151 ppr_core_default sty pbdr1 pbdr2 pocc deflt
152 = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
155 %************************************************************************
157 \subsection{Instance declarations for Core printing}
159 %************************************************************************
163 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
164 Eq uvar, Outputable uvar)
166 Outputable (GenCoreBinding bndr occ tyvar uvar) where
167 ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
170 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
171 Eq uvar, Outputable uvar)
173 Outputable (GenCoreExpr bndr occ tyvar uvar) where
174 ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
177 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
179 Outputable (GenCoreArg occ tyvar uvar) where
180 ppr sty arg = ppr_core_arg sty (ppr sty) arg
183 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
184 Eq uvar, Outputable uvar)
186 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
187 ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
190 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
191 Eq uvar, Outputable uvar)
193 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
194 ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
197 %************************************************************************
199 \subsection{Workhorse routines (...????...)}
201 %************************************************************************
204 ppr_bind pe (NonRec val_bdr expr)
205 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
208 ppr_bind pe (Rec binds)
209 = ppAboves [ ppStr "{- Rec -}",
210 ppAboves (map ppr_pair binds),
211 ppStr "{- end Rec -}" ]
213 ppr_pair (val_bdr, expr)
214 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
219 ppr_parend_expr pe expr
223 Var _ -> id -- leave unchanged
225 _ -> ppParens -- wraps in parens
227 parenify (ppr_expr pe expr)
231 ppr_expr pe (Var name) = pOcc pe name
232 ppr_expr pe (Lit lit) = pLit pe lit
233 ppr_expr pe (Con con []) = pCon pe con
235 ppr_expr pe (Con con args)
236 = ppHang (ppBesides [pCon pe con, ppChar '!'])
237 4 (ppSep (map (ppr_arg pe) args))
239 ppr_expr pe (Prim prim args)
240 = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
241 4 (ppSep (map (ppr_arg pe) args))
243 ppr_expr pe expr@(Lam _ _)
245 (uvars, tyvars, vars, body) = collectBinders expr
247 ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars,
248 pp_vars SLIT("_/\\_") (pTyVar pe) tyvars,
249 pp_vars SLIT("\\") (pMinBndr pe) vars])
252 pp_vars lam pp [] = ppNil
254 = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
256 ppr_expr pe expr@(App _ _)
258 (fun, uargs, targs, vargs) = collectArgs expr
260 ppHang (ppr_parend_expr pe fun)
261 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
262 , ppInterleave ppNil (map (pTy pe) targs)
263 , ppInterleave ppNil (map (ppr_arg pe) vargs)
266 ppr_expr pe (Case expr alts)
268 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
269 ppNest 2 (ppr_alts pe alts),
272 -- special cases: let ... in let ...
273 -- ("disgusting" SLPJ)
275 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
277 ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
278 ppNest 2 (ppr_expr pe rhs),
282 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
284 (ppHang (ppStr "let {")
285 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
290 -- general case (recursive case, too)
291 ppr_expr pe (Let bind expr)
292 = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
293 ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
295 ppr_expr pe (SCC cc expr)
296 = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
297 ppr_parend_expr pe expr ]
301 ppr_alts pe (AlgAlts alts deflt)
302 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
304 ppr_alt (con, params, expr)
305 = ppHang (ppCat [ppr_con con (pCon pe con),
306 ppInterleave ppSP (map (pMinBndr pe) params),
311 = if isOpLexeme con then ppParens pp_con else pp_con
313 ppr_alts pe (PrimAlts alts deflt)
314 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
317 = ppHang (ppCat [pLit pe lit, ppStr "->"])
322 ppr_default pe NoDefault = ppNil
324 ppr_default pe (BindDefault val_bdr expr)
325 = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
330 ppr_arg pe (LitArg lit) = pLit pe lit
331 ppr_arg pe (VarArg v) = pOcc pe v
332 ppr_arg pe (TyArg ty) = pTy pe ty
333 ppr_arg pe (UsageArg use) = pUse pe use
336 Other printing bits-and-bobs used with the general @pprCoreBinding@
337 and @pprCoreExpr@ functions.
340 pprBigCoreBinder sty binder
341 = ppAboves [sig, pragmas, ppr sty binder]
343 sig = ifnotPprShowAll sty (
344 ppHang (ppCat [ppr sty binder, ppStr "::"])
345 4 (ppr sty (idType binder)))
349 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
352 pprBabyCoreBinder sty binder
353 = ppCat [ppr sty binder, pp_strictness]
356 = case (getIdStrictness binder) of
357 NoStrictnessInfo -> ppNil
358 BottomGuaranteed -> ppStr "{- _!_ -}"
359 StrictnessInfo xx _ ->
360 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
361 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
363 pprTypedCoreBinder sty binder
364 = ppBesides [ppLparen, ppCat [ppr sty binder,
365 ppStr "::", ppr sty (idType binder)],