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-}
33 import IdInfo ( ppIdInfo, StrictnessInfo(..) )
34 import Literal ( Literal{-instances-} )
35 import Name ( OccName, parenInCode )
36 import Outputable -- quite a few things
38 import PprType ( pprParendGenType, pprTyVarBndr, 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 (ppr sty) pbdr1 pbdr2 pocc) bind
85 init_ppr_env sty tvbndr 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 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 pprCoreBinding sty (NonRec binder expr)
100 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
101 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
103 pprCoreBinding sty (Rec binds)
104 = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
105 ppAboves (map ppr_bind binds),
106 ifPprDebug sty (ppStr "{- end plain Rec -}")]
108 ppr_bind (binder, expr)
109 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
110 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
116 -> (Id -> Pretty) -- to print "major" val_bdrs
117 -> (Id -> Pretty) -- to print "minor" val_bdrs
118 -> (Id -> Pretty) -- to print bindees
121 pprCoreExpr = pprGenCoreExpr
123 pprGenCoreExpr, pprParendCoreExpr
124 :: (Eq tyvar, Outputable tyvar,
125 Eq uvar, Outputable uvar,
129 -> (bndr -> Pretty) -- to print "major" val_bdrs
130 -> (bndr -> Pretty) -- to print "minor" val_bdrs
131 -> (occ -> Pretty) -- to print bindees
132 -> GenCoreExpr bndr occ tyvar uvar
135 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
136 = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
138 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
142 Var _ -> id -- leave unchanged
144 _ -> ppParens -- wraps in parens
146 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
148 -- Printer for unfoldings in interfaces
149 pprIfaceUnfolding :: CoreExpr -> Pretty
150 pprIfaceUnfolding = ppr_expr env
152 env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
153 (pprTypedCoreBinder PprInterface)
154 (pprTypedCoreBinder PprInterface)
157 ppr_core_arg sty pocc arg
158 = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
160 ppr_core_alts sty pbdr1 pbdr2 pocc alts
161 = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
163 ppr_core_default sty pbdr1 pbdr2 pocc deflt
164 = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
167 %************************************************************************
169 \subsection{Instance declarations for Core printing}
171 %************************************************************************
175 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
176 Eq uvar, Outputable uvar)
178 Outputable (GenCoreBinding bndr occ tyvar uvar) where
179 ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
182 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
183 Eq uvar, Outputable uvar)
185 Outputable (GenCoreExpr bndr occ tyvar uvar) where
186 ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
189 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
191 Outputable (GenCoreArg occ tyvar uvar) where
192 ppr sty arg = ppr_core_arg sty (ppr sty) arg
195 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
196 Eq uvar, Outputable uvar)
198 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
199 ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
202 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
203 Eq uvar, Outputable uvar)
205 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
206 ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
209 %************************************************************************
211 \subsection{Workhorse routines (...????...)}
213 %************************************************************************
216 ppr_bind pe (NonRec val_bdr expr)
217 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
220 ppr_bind pe (Rec binds)
221 = ppAboves (map ppr_pair binds)
223 ppr_pair (val_bdr, expr)
224 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
225 4 (ppr_expr pe expr `ppBeside` ppSemi)
229 ppr_parend_expr pe expr
233 Var _ -> id -- leave unchanged
235 _ -> ppParens -- wraps in parens
237 parenify (ppr_expr pe expr)
241 ppr_expr pe (Var name) = pOcc pe name
242 ppr_expr pe (Lit lit) = pLit pe lit
243 ppr_expr pe (Con con []) = pCon pe con
245 ppr_expr pe (Con con args)
246 = ppHang (ppBesides [pCon pe con, ppChar '!'])
247 4 (ppSep (map (ppr_arg pe) args))
249 ppr_expr pe (Prim prim args)
250 = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
251 4 (ppSep (map (ppr_arg pe) args))
253 ppr_expr pe expr@(Lam _ _)
255 (uvars, tyvars, vars, body) = collectBinders expr
257 ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
258 pp_vars SLIT("/\\") (pTyVarB pe) tyvars,
259 pp_vars SLIT("\\") (pMinBndr pe) vars])
262 pp_vars lam pp [] = ppNil
264 = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
266 ppr_expr pe expr@(App _ _)
268 (fun, uargs, targs, vargs) = collectArgs expr
270 ppHang (ppr_parend_expr pe fun)
271 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
272 , ppInterleave ppNil (map (pTy pe) targs)
273 , ppInterleave ppNil (map (ppr_arg pe) vargs)
276 ppr_expr pe (Case expr alts)
278 -- johan thinks that single case patterns should be on same line as case,
279 -- and no indent; all sane persons agree with him.
281 ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
282 ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
283 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
284 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
285 = ppCat [ppr_alt_con con (pCon pe con),
286 ppInterleave ppSP (map (pMinBndr pe) params),
289 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
290 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
291 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
292 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
295 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
296 ppBeside (ppr_rhs alts) (ppStr ";}")]
298 | otherwise -- default "case" printing
300 [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"],
301 ppNest 2 (ppr_alts pe alts),
304 -- special cases: let ... in let ...
305 -- ("disgusting" SLPJ)
307 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
309 ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
310 ppNest 2 (ppr_expr pe rhs),
314 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
316 (ppHang (ppStr "let {")
317 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
322 -- general case (recursive case, too)
323 ppr_expr pe (Let bind expr)
324 = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind),
325 ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
327 keyword = case bind of
329 NonRec _ _ -> "let {"
331 ppr_expr pe (SCC cc expr)
332 = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
333 ppr_parend_expr pe expr ]
335 ppr_expr pe (Coerce c ty expr)
336 = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ]
338 pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v)
339 pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v)
341 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
342 only_one_alt (AlgAlts (_:[]) NoDefault) = True
343 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
344 only_one_alt (PrimAlts (_:[]) NoDefault) = True
345 only_one_alt _ = False
347 ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con
351 ppr_alts pe (AlgAlts alts deflt)
352 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
354 ppr_alt (con, params, expr)
355 = ppHang (if isTupleCon con then
356 ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
359 ppCat [ppr_alt_con con (pCon pe con),
360 ppInterleave ppSP (map (pMinBndr pe) params),
363 4 (ppr_expr pe expr `ppBeside` ppSemi)
365 ppr_alts pe (PrimAlts alts deflt)
366 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
369 = ppHang (ppCat [pLit pe lit, ppStr "->"])
370 4 (ppr_expr pe expr `ppBeside` ppSemi)
374 ppr_default pe NoDefault = ppNil
376 ppr_default pe (BindDefault val_bdr expr)
377 = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
378 4 (ppr_expr pe expr `ppBeside` ppSemi)
382 ppr_arg pe (LitArg lit) = pLit pe lit
383 ppr_arg pe (VarArg v) = pOcc pe v
384 ppr_arg pe (TyArg ty) = pTy pe ty
385 ppr_arg pe (UsageArg use) = pUse pe use
388 Other printing bits-and-bobs used with the general @pprCoreBinding@
389 and @pprCoreExpr@ functions.
392 pprBigCoreBinder sty binder
393 = ppAboves [sig, pragmas, ppr sty binder]
395 sig = ifnotPprShowAll sty (
396 ppHang (ppCat [ppr sty binder, ppStr "::"])
397 4 (ppr sty (idType binder)))
401 (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
403 pprBabyCoreBinder sty binder
404 = ppCat [ppr sty binder, pp_strictness]
407 = case (getIdStrictness binder) of
408 NoStrictnessInfo -> ppNil
409 BottomGuaranteed -> ppStr "{- _!_ -}"
410 StrictnessInfo xx _ ->
411 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
412 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
414 pprTypedCoreBinder sty binder
415 = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)]