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__ <= 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-}
33 import IdInfo ( ppIdInfo, StrictnessInfo(..) )
34 import Literal ( Literal{-instances-} )
35 import Name ( isSymLexeme )
36 import Outputable -- quite a few things
38 import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
39 import PprStyle ( PprStyle(..) )
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@...) @Pretty@ 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 -> Pretty
71 :: (Eq tyvar, Outputable tyvar,
72 Eq uvar, Outputable uvar,
76 -> (bndr -> Pretty) -- to print "major" val_bdrs
77 -> (bndr -> Pretty) -- to print "minor" val_bdrs
78 -> (occ -> Pretty) -- to print bindees
79 -> GenCoreBinding bndr occ tyvar uvar
82 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
83 = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
85 init_ppr_env sty pbdr1 pbdr2 pocc
87 (Just (ppr sty)) -- literals
88 (Just (ppr sty)) -- data cons
89 (Just (ppr sty)) -- primops
90 (Just (\ cc -> ppStr (showCostCentre sty True cc)))
91 (Just (ppr sty)) -- tyvars
92 (Just (ppr sty)) -- usage vars
93 (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
94 (Just (pprParendGenType sty)) -- types
95 (Just (ppr sty)) -- usages
98 pprCoreBinding sty (NonRec binder expr)
99 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
100 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
102 pprCoreBinding sty (Rec binds)
103 = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
104 ppAboves (map ppr_bind binds),
105 ifPprDebug sty (ppStr "{- end plain Rec -}")]
107 ppr_bind (binder, expr)
108 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
109 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
115 -> (Id -> Pretty) -- to print "major" val_bdrs
116 -> (Id -> Pretty) -- to print "minor" val_bdrs
117 -> (Id -> Pretty) -- to print bindees
120 pprCoreExpr = pprGenCoreExpr
122 pprGenCoreExpr, pprParendCoreExpr
123 :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
127 -> (bndr -> Pretty) -- to print "major" val_bdrs
128 -> (bndr -> Pretty) -- to print "minor" val_bdrs
129 -> (occ -> Pretty) -- to print bindees
130 -> GenCoreExpr bndr occ tyvar uvar
133 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
134 = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
136 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
140 Var _ -> id -- leave unchanged
142 _ -> ppParens -- wraps in parens
144 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
146 ppr_core_arg sty pocc arg
147 = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
149 ppr_core_alts sty pbdr1 pbdr2 pocc alts
150 = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
152 ppr_core_default sty pbdr1 pbdr2 pocc deflt
153 = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
156 %************************************************************************
158 \subsection{Instance declarations for Core printing}
160 %************************************************************************
164 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
165 Eq uvar, Outputable uvar)
167 Outputable (GenCoreBinding bndr occ tyvar uvar) where
168 ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
171 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
172 Eq uvar, Outputable uvar)
174 Outputable (GenCoreExpr bndr occ tyvar uvar) where
175 ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
178 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
180 Outputable (GenCoreArg occ tyvar uvar) where
181 ppr sty arg = ppr_core_arg sty (ppr sty) arg
184 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
185 Eq uvar, Outputable uvar)
187 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
188 ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
191 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
192 Eq uvar, Outputable uvar)
194 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
195 ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
198 %************************************************************************
200 \subsection{Workhorse routines (...????...)}
202 %************************************************************************
205 ppr_bind pe (NonRec val_bdr expr)
206 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
209 ppr_bind pe (Rec binds)
210 = ppAboves [ ppStr "{- Rec -}",
211 ppAboves (map ppr_pair binds),
212 ppStr "{- end Rec -}" ]
214 ppr_pair (val_bdr, expr)
215 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
220 ppr_parend_expr pe expr
224 Var _ -> id -- leave unchanged
226 _ -> ppParens -- wraps in parens
228 parenify (ppr_expr pe expr)
232 ppr_expr pe (Var name) = pOcc pe name
233 ppr_expr pe (Lit lit) = pLit pe lit
234 ppr_expr pe (Con con []) = pCon pe con
236 ppr_expr pe (Con con args)
237 = ppHang (ppBesides [pCon pe con, ppChar '!'])
238 4 (ppSep (map (ppr_arg pe) args))
240 ppr_expr pe (Prim prim args)
241 = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
242 4 (ppSep (map (ppr_arg pe) args))
244 ppr_expr pe expr@(Lam _ _)
246 (uvars, tyvars, vars, body) = collectBinders expr
248 ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars,
249 pp_vars SLIT("_/\\_") (pTyVar pe) tyvars,
250 pp_vars SLIT("\\") (pMinBndr pe) vars])
253 pp_vars lam pp [] = ppNil
255 = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
257 ppr_expr pe expr@(App _ _)
259 (fun, uargs, targs, vargs) = collectArgs expr
261 ppHang (ppr_parend_expr pe fun)
262 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
263 , ppInterleave ppNil (map (pTy pe) targs)
264 , ppInterleave ppNil (map (ppr_arg pe) vargs)
267 ppr_expr pe (Case expr alts)
269 -- johan thinks that single case patterns should be on same line as case,
270 -- and no indent; all sane persons agree with him.
272 ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
273 ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
274 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
275 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
276 = ppCat [ppr_alt_con con (pCon pe con),
277 ppInterleave ppSP (map (pMinBndr pe) params),
280 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
281 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
282 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
283 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
286 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
287 ppBeside (ppr_rhs alts) (ppStr "}")]
289 | otherwise -- default "case" printing
291 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
292 ppNest 2 (ppr_alts pe alts),
295 -- special cases: let ... in let ...
296 -- ("disgusting" SLPJ)
298 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
300 ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
301 ppNest 2 (ppr_expr pe rhs),
305 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
307 (ppHang (ppStr "let {")
308 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
313 -- general case (recursive case, too)
314 ppr_expr pe (Let bind expr)
315 = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
316 ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
318 ppr_expr pe (SCC cc expr)
319 = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
320 ppr_parend_expr pe expr ]
322 ppr_expr pe (Coerce c ty expr)
323 = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
324 pTy pe ty, ppr_parend_expr pe expr ]
326 pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
327 pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
329 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
330 only_one_alt (AlgAlts (_:[]) NoDefault) = True
331 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
332 only_one_alt (PrimAlts (_:[]) NoDefault) = True
333 only_one_alt _ = False
335 ppr_alt_con con pp_con
336 = if isSymLexeme con then ppParens pp_con else pp_con
340 ppr_alts pe (AlgAlts alts deflt)
341 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
343 ppr_alt (con, params, expr)
344 = ppHang (if isTupleCon con then
345 ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
348 ppCat [ppr_alt_con con (pCon pe con),
349 ppInterleave ppSP (map (pMinBndr pe) params),
354 ppr_alts pe (PrimAlts alts deflt)
355 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
358 = ppHang (ppCat [pLit pe lit, ppStr "->"])
363 ppr_default pe NoDefault = ppNil
365 ppr_default pe (BindDefault val_bdr expr)
366 = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
371 ppr_arg pe (LitArg lit) = pLit pe lit
372 ppr_arg pe (VarArg v) = pOcc pe v
373 ppr_arg pe (TyArg ty) = pTy pe ty
374 ppr_arg pe (UsageArg use) = pUse pe use
377 Other printing bits-and-bobs used with the general @pprCoreBinding@
378 and @pprCoreExpr@ functions.
381 pprBigCoreBinder sty binder
382 = ppAboves [sig, pragmas, ppr sty binder]
384 sig = ifnotPprShowAll sty (
385 ppHang (ppCat [ppr sty binder, ppStr "::"])
386 4 (ppr sty (idType binder)))
390 (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
393 pprBabyCoreBinder sty binder
394 = ppCat [ppr sty binder, pp_strictness]
397 = case (getIdStrictness binder) of
398 NoStrictnessInfo -> ppNil
399 BottomGuaranteed -> ppStr "{- _!_ -}"
400 StrictnessInfo xx _ ->
401 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
402 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
404 pprTypedCoreBinder sty binder
405 = ppBesides [ppLparen, ppCat [ppr sty binder,
406 ppStr "::", ppr sty (idType binder)],