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(..), ifaceStyle )
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_con) -- data cons
89 (Just ppr_prim) -- 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
98 -- ppr_con is used when printing Con expressions; we add a "!"
99 -- to distinguish them from ordinary applications. But not when
100 -- printing for interfaces, where they are treated as ordinary applications
101 ppr_con con | ifaceStyle sty = ppr sty con
102 | otherwise = ppr sty con `ppBeside` ppChar '!'
104 -- We add a "!" to distinguish Primitive applications from ordinary applications.
105 -- But not when printing for interfaces, where they are treated
106 -- as ordinary applications
107 ppr_prim prim | ifaceStyle sty = ppr sty prim
108 | otherwise = ppr sty prim `ppBeside` ppChar '!'
111 pprCoreBinding sty (NonRec binder expr)
112 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
113 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
115 pprCoreBinding sty (Rec binds)
116 = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
117 ppAboves (map ppr_bind binds),
118 ifPprDebug sty (ppStr "{- end plain Rec -}")]
120 ppr_bind (binder, expr)
121 = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
122 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
128 -> (Id -> Pretty) -- to print "major" val_bdrs
129 -> (Id -> Pretty) -- to print "minor" val_bdrs
130 -> (Id -> Pretty) -- to print bindees
133 pprCoreExpr = pprGenCoreExpr
135 pprGenCoreExpr, pprParendCoreExpr
136 :: (Eq tyvar, Outputable tyvar,
137 Eq uvar, Outputable uvar,
141 -> (bndr -> Pretty) -- to print "major" val_bdrs
142 -> (bndr -> Pretty) -- to print "minor" val_bdrs
143 -> (occ -> Pretty) -- to print bindees
144 -> GenCoreExpr bndr occ tyvar uvar
147 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
148 = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
150 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
154 Var _ -> id -- leave unchanged
156 _ -> ppParens -- wraps in parens
158 parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
160 -- Printer for unfoldings in interfaces
161 pprIfaceUnfolding :: CoreExpr -> Pretty
162 pprIfaceUnfolding = ppr_expr env
164 env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
165 (pprTypedCoreBinder PprInterface)
166 (pprTypedCoreBinder PprInterface)
169 ppr_core_arg sty pocc arg
170 = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
172 ppr_core_alts sty pbdr1 pbdr2 pocc alts
173 = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
175 ppr_core_default sty pbdr1 pbdr2 pocc deflt
176 = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
179 %************************************************************************
181 \subsection{Instance declarations for Core printing}
183 %************************************************************************
187 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
188 Eq uvar, Outputable uvar)
190 Outputable (GenCoreBinding bndr occ tyvar uvar) where
191 ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
194 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
195 Eq uvar, Outputable uvar)
197 Outputable (GenCoreExpr bndr occ tyvar uvar) where
198 ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
201 (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
203 Outputable (GenCoreArg occ tyvar uvar) where
204 ppr sty arg = ppr_core_arg sty (ppr sty) arg
207 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
208 Eq uvar, Outputable uvar)
210 Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
211 ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
214 (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
215 Eq uvar, Outputable uvar)
217 Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
218 ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
221 %************************************************************************
223 \subsection{Workhorse routines (...????...)}
225 %************************************************************************
228 ppr_bind pe (NonRec val_bdr expr)
229 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
232 ppr_bind pe (Rec binds)
233 = ppAboves (map ppr_pair binds)
235 ppr_pair (val_bdr, expr)
236 = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
237 4 (ppr_expr pe expr `ppBeside` ppSemi)
241 ppr_parend_expr pe expr
245 Var _ -> id -- leave unchanged
247 _ -> ppParens -- wraps in parens
249 parenify (ppr_expr pe expr)
253 ppr_expr pe (Var name) = pOcc pe name
254 ppr_expr pe (Lit lit) = pLit pe lit
255 ppr_expr pe (Con con []) = pCon pe con
257 ppr_expr pe (Con con args)
258 = ppHang (pCon pe con)
259 4 (ppSep (map (ppr_arg pe) args))
261 ppr_expr pe (Prim prim args)
262 = ppHang (pPrim pe prim)
263 4 (ppSep (map (ppr_arg pe) args))
265 ppr_expr pe expr@(Lam _ _)
267 (uvars, tyvars, vars, body) = collectBinders expr
269 ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
270 pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
271 pp_vars SLIT("\\") (pMinBndr pe) vars])
274 pp_vars lam pp [] = ppNil
276 = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
278 ppr_expr pe expr@(App fun arg)
280 (final_fun, final_args) = go fun [arg]
281 go (App fun arg) args_so_far = go fun (arg:args_so_far)
282 go fun args_so_far = (fun, args_so_far)
284 ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args))
286 ppr_expr pe (Case expr alts)
288 -- johan thinks that single case patterns should be on same line as case,
289 -- and no indent; all sane persons agree with him.
291 ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
292 ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
293 ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
294 ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
295 = ppCat [pCon pe con,
296 ppInterleave ppSP (map (pMinBndr pe) params),
299 ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
300 ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
301 ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
302 ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
305 [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
306 ppBeside (ppr_rhs alts) (ppStr ";}")]
308 | otherwise -- default "case" printing
310 [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"],
311 ppNest 2 (ppr_alts pe alts),
314 pp_keyword = case alts of
315 AlgAlts _ _ -> ppPStr SLIT("case")
316 PrimAlts _ _ -> ppPStr SLIT("case#")
318 -- special cases: let ... in let ...
319 -- ("disgusting" SLPJ)
321 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
323 ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
324 ppNest 2 (ppr_expr pe rhs),
328 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
330 (ppHang (ppStr "let {")
331 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
336 -- general case (recursive case, too)
337 ppr_expr pe (Let bind expr)
338 = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind),
339 ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
341 keyword = case bind of
343 NonRec _ _ -> "let {"
345 ppr_expr pe (SCC cc expr)
346 = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
347 ppr_parend_expr pe expr ]
349 ppr_expr pe (Coerce c ty expr)
350 = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
352 pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v)
353 pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v)
355 only_one_alt (AlgAlts [] (BindDefault _ _)) = True
356 only_one_alt (AlgAlts (_:[]) NoDefault) = True
357 only_one_alt (PrimAlts [] (BindDefault _ _)) = True
358 only_one_alt (PrimAlts (_:[]) NoDefault) = True
359 only_one_alt _ = False
363 ppr_alts pe (AlgAlts alts deflt)
364 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
366 ppr_alt (con, params, expr)
367 = ppHang (if isTupleCon con then
368 ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
372 ppInterleave ppSP (map (pMinBndr pe) params),
375 4 (ppr_expr pe expr `ppBeside` ppSemi)
377 ppr_alts pe (PrimAlts alts deflt)
378 = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
381 = ppHang (ppCat [pLit pe lit, ppStr "->"])
382 4 (ppr_expr pe expr `ppBeside` ppSemi)
386 ppr_default pe NoDefault = ppNil
388 ppr_default pe (BindDefault val_bdr expr)
389 = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
390 4 (ppr_expr pe expr `ppBeside` ppSemi)
394 ppr_arg pe (LitArg lit) = pLit pe lit
395 ppr_arg pe (VarArg v) = pOcc pe v
396 ppr_arg pe (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty
397 ppr_arg pe (UsageArg use) = pUse pe use
400 Other printing bits-and-bobs used with the general @pprCoreBinding@
401 and @pprCoreExpr@ functions.
404 pprBigCoreBinder sty binder
405 = ppAboves [sig, pragmas, ppr sty binder]
407 sig = ifnotPprShowAll sty (
408 ppHang (ppCat [ppr sty binder, ppDcolon])
409 4 (ppr sty (idType binder)))
412 (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
414 pprBabyCoreBinder sty binder
415 = ppCat [ppr sty binder, pp_strictness]
418 = case (getIdStrictness binder) of
419 NoStrictnessInfo -> ppNil
420 BottomGuaranteed -> ppStr "{- _!_ -}"
421 StrictnessInfo xx _ ->
422 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
423 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
425 pprTypedCoreBinder sty binder
426 = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
428 ppDcolon = ppStr " :: "
429 -- The space before the :: is important; it helps the lexer
430 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.