2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprParendExpr,
13 pprCoreBinding, pprCoreBindings, pprIdBndr,
14 pprCoreBinding, pprCoreBindings, pprCoreAlt,
15 pprCoreRules, pprCoreRule, pprIdCoreRule
18 #include "HsVersions.h"
21 import CostCentre ( pprCostCentreCore )
22 import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
23 idInfo, idInlinePragma, idDemandInfo, idOccInfo,
24 globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
26 import Var ( isTyVar )
27 import IdInfo ( IdInfo, megaSeqIdInfo,
28 arityInfo, ppArityInfo,
29 specInfo, cprInfo, ppCprInfo,
30 strictnessInfo, ppStrictnessInfo,
32 workerInfo, ppWorkerInfo,
33 tyGenInfo, ppTyGenInfo,
34 newDemandInfo, newStrictnessInfo
36 import DataCon ( dataConTyCon )
37 import TyCon ( tupleTyConBoxity, isTupleTyCon )
38 import PprType ( pprParendType, pprTyVarBndr )
39 import BasicTypes ( tupleParens )
44 %************************************************************************
46 \subsection{Public interfaces for Core printing (excluding instances)}
48 %************************************************************************
50 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
51 function for ``major'' val_bdrs (those next to equal signs :-),
52 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
53 usually be called through some intermediary.
55 The binder/occ printers take the default ``homogenized'' (see
56 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
57 homogenized one, or they can ignore it completely. In other words,
58 the things passed in act as ``hooks'', getting the last word on how to
61 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
63 Un-annotated core dumps
64 ~~~~~~~~~~~~~~~~~~~~~~~
66 pprCoreBindings :: [CoreBind] -> SDoc
67 pprCoreBinding :: CoreBind -> SDoc
68 pprCoreExpr :: CoreExpr -> SDoc
69 pprParendExpr :: CoreExpr -> SDoc
71 pprCoreBindings = pprTopBinds pprCoreEnv
72 pprCoreBinding = pprTopBind pprCoreEnv
73 pprCoreExpr = ppr_noparend_expr pprCoreEnv
74 pprParendExpr = ppr_parend_expr pprCoreEnv
75 pprArg = ppr_arg pprCoreEnv
76 pprCoreAlt = ppr_alt pprCoreEnv
78 pprCoreEnv = initCoreEnv pprCoreBinder
81 Printer for unfoldings in interfaces
82 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
84 instance Outputable b => Outputable (Bind b) where
85 ppr bind = ppr_bind pprGenericEnv bind
87 instance Outputable b => Outputable (Expr b) where
88 ppr expr = ppr_noparend_expr pprGenericEnv expr
90 pprGenericEnv :: Outputable b => PprEnv b
91 pprGenericEnv = initCoreEnv (\site -> ppr)
94 %************************************************************************
96 \subsection{Instance declarations for Core printing}
98 %************************************************************************
104 (Just pprCostCentreCore) -- Cost centres
106 (Just ppr) -- tyvar occs
107 (Just pprParendType) -- types
109 (Just pbdr) (Just ppr) -- value vars
110 -- Use pprIdBndr for this last one as a debugging device.
113 %************************************************************************
115 \subsection{The guts}
117 %************************************************************************
120 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
122 pprTopBind pe (NonRec binder expr)
123 = ppr_binding_pe pe (binder,expr) $$ text ""
125 pprTopBind pe (Rec binds)
126 = vcat [ptext SLIT("Rec {"),
127 vcat (map (ppr_binding_pe pe) binds),
128 ptext SLIT("end Rec }"),
133 ppr_bind :: PprEnv b -> Bind b -> SDoc
135 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
136 ppr_bind pe (Rec binds) = vcat (map pp binds)
138 pp bind = ppr_binding_pe pe bind <> semi
140 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
141 ppr_binding_pe pe (val_bdr, expr)
142 = sep [pBndr pe LetBind val_bdr,
143 nest 2 (equals <+> ppr_noparend_expr pe expr)]
147 ppr_parend_expr pe expr = ppr_expr parens pe expr
148 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
150 noParens :: SDoc -> SDoc
155 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
156 -- The function adds parens in context that need
157 -- an atomic value (e.g. function args)
159 ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
161 ppr_expr add_par pe (Var name) = pOcc pe name
162 ppr_expr add_par pe (Lit lit) = ppr lit
164 ppr_expr add_par pe expr@(Lam _ _)
166 (bndrs, body) = collectBinders expr
169 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
170 2 (ppr_noparend_expr pe body)
172 ppr_expr add_par pe expr@(App fun arg)
173 = case collectArgs expr of { (fun, args) ->
175 pp_args = sep (map (ppr_arg pe) args)
176 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
177 pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
180 Var f -> case isDataConId_maybe f of
181 -- Notice that we print the *worker*
182 -- for tuples in paren'd format.
183 Just dc | saturated && isTupleTyCon tc
184 -> tupleParens (tupleTyConBoxity tc) pp_tup_args
187 saturated = length val_args == idArity f
189 other -> add_par (hang (pOcc pe f) 2 pp_args)
191 other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
194 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
196 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
197 hsep [ptext SLIT("of"),
200 ppr_case_pat pe con args
202 ppr_noparend_expr pe rhs,
206 ppr_bndr = pBndr pe CaseBind
208 ppr_expr add_par pe (Case expr var alts)
210 sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
211 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
212 nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
216 ppr_bndr = pBndr pe CaseBind
219 -- special cases: let ... in let ...
220 -- ("disgusting" SLPJ)
222 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
225 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
226 nest 2 (ppr_noparend_expr pe rhs),
228 ppr_noparend_expr pe body ]
230 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
232 (hang (ptext SLIT("let {"))
233 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
234 2 (ppr_noparend_expr pe rhs),
237 ppr_noparend_expr pe expr)
239 -- general case (recursive case, too)
240 ppr_expr add_par pe (Let bind expr)
242 sep [hang (ptext keyword) 2 (ppr_bind pe bind),
243 hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
245 keyword = case bind of
246 Rec _ -> SLIT("__letrec {")
247 NonRec _ _ -> SLIT("let {")
249 ppr_expr add_par pe (Note (SCC cc) expr)
250 = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
253 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
255 getPprStyle $ \ sty ->
256 if debugStyle sty && not (ifaceStyle sty) then
257 sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
258 ppr_parend_expr pe expr]
260 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
261 ppr_parend_expr pe expr]
263 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
265 sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
266 ppr_parend_expr pe expr]
269 ppr_expr add_par pe (Note InlineCall expr)
270 = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
272 ppr_expr add_par pe (Note InlineMe expr)
273 = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
275 ppr_alt pe (con, args, rhs)
276 = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
278 ppr_case_pat pe con@(DataAlt dc) args
280 = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
282 ppr_bndr = pBndr pe CaseBind
285 ppr_case_pat pe con args
286 = ppr con <+> hsep (map ppr_bndr args) <+> arrow
288 ppr_bndr = pBndr pe CaseBind
290 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
291 ppr_arg pe expr = ppr_parend_expr pe expr
293 arrow = ptext SLIT("->")
296 Other printing bits-and-bobs used with the general @pprCoreBinding@
297 and @pprCoreExpr@ functions.
300 -- Used for printing dump info
301 pprCoreBinder LetBind binder
302 = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
304 sig = pprTypedBinder binder
305 pragmas = ppIdInfo binder (idInfo binder)
307 -- Lambda bound type variables are preceded by "@"
308 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
310 -- Case bound things don't get a signature or a herald
311 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
313 pprUntypedBinder binder
314 | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
315 | otherwise = pprIdBndr binder
317 pprTypedBinder binder
318 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
319 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
320 -- The space before the :: is important; it helps the lexer
321 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
323 -- It's important that the type is parenthesised too, at least when
324 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
326 -- pprIdBndr does *not* print the type
327 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
328 pprIdBndr id = ppr id <+>
329 (megaSeqIdInfo (idInfo id) `seq`
330 -- Useful for poking on black holes
331 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
332 ppr (idDemandInfo id)) <+> ppr (newDemandInfo (idInfo id)) <+>
333 ppr (idLBVarInfo id))
338 pprIdDetails :: Id -> SDoc
339 pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
340 | isExportedId id = ptext SLIT("[Exported]")
341 | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
344 ppIdInfo :: Id -> IdInfo -> SDoc
346 = hsep [ ppArityInfo a,
348 ppWorkerInfo (workerInfo info),
350 ppr (newStrictnessInfo info),
353 -- Inline pragma, occ, demand, lbvar info
354 -- printed out with all binders (when debug is on);
355 -- see PprCore.pprIdBndr
360 s = strictnessInfo info
367 pprCoreRules :: Id -> CoreRules -> SDoc
368 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
370 pprIdCoreRule :: IdCoreRule -> SDoc
371 pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
373 pprCoreRule :: SDoc -> CoreRule -> SDoc
374 pprCoreRule pp_fn (BuiltinRule name _)
375 = ifPprDebug (ptext SLIT("Built in rule") <+> doubleQuotes (ptext name))
377 pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
378 = doubleQuotes (ptext name) <+> ppr act <+>
380 ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
381 nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
382 nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)