2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 %************************************************************************
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
8 %************************************************************************
12 pprCoreExpr, pprParendExpr, pprIfaceUnfolding,
13 pprCoreBinding, pprCoreBindings,
14 pprCoreRules, pprCoreRule
17 #include "HsVersions.h"
20 import CostCentre ( pprCostCentreCore )
21 import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
22 idInfo, idInlinePragma, idDemandInfo, idOccInfo
24 import Var ( isTyVar )
25 import IdInfo ( IdInfo, megaSeqIdInfo, occInfo,
26 arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
27 demandInfo, updateInfo, ppUpdateInfo, specInfo,
28 strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
29 cprInfo, ppCprInfo, lbvarInfo,
30 workerInfo, ppWorkerInfo
32 import DataCon ( isTupleCon, isUnboxedTupleCon )
33 import PprType ( pprParendType, pprTyVarBndr )
38 %************************************************************************
40 \subsection{Public interfaces for Core printing (excluding instances)}
42 %************************************************************************
44 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
45 function for ``major'' val_bdrs (those next to equal signs :-),
46 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
47 usually be called through some intermediary.
49 The binder/occ printers take the default ``homogenized'' (see
50 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
51 homogenized one, or they can ignore it completely. In other words,
52 the things passed in act as ``hooks'', getting the last word on how to
55 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
57 Un-annotated core dumps
58 ~~~~~~~~~~~~~~~~~~~~~~~
60 pprCoreBindings :: [CoreBind] -> SDoc
61 pprCoreBinding :: CoreBind -> SDoc
62 pprCoreExpr :: CoreExpr -> SDoc
63 pprParendExpr :: CoreExpr -> SDoc
65 pprCoreBindings = pprTopBinds pprCoreEnv
66 pprCoreBinding = pprTopBind pprCoreEnv
67 pprCoreExpr = ppr_noparend_expr pprCoreEnv
68 pprParendExpr = ppr_parend_expr pprCoreEnv
70 pprCoreEnv = initCoreEnv pprCoreBinder
73 Printer for unfoldings in interfaces
74 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 pprIfaceUnfolding :: CoreExpr -> SDoc
77 pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
78 -- Notice that it's parenthesised
80 pprIfaceArg = ppr_arg pprIfaceEnv
82 pprIfaceEnv = initCoreEnv pprIfaceBinder
86 instance Outputable b => Outputable (Bind b) where
87 ppr bind = ppr_bind pprGenericEnv bind
89 instance Outputable b => Outputable (Expr b) where
90 ppr expr = ppr_noparend_expr pprGenericEnv expr
92 pprGenericEnv :: Outputable b => PprEnv b
93 pprGenericEnv = initCoreEnv (\site -> ppr)
96 %************************************************************************
98 \subsection{Instance declarations for Core printing}
100 %************************************************************************
106 (Just pprCostCentreCore) -- Cost centres
108 (Just ppr) -- tyvar occs
109 (Just pprParendType) -- types
111 (Just pbdr) (Just ppr) -- value vars
112 -- Use pprIdBndr for this last one as a debugging device.
115 %************************************************************************
117 \subsection{The guts}
119 %************************************************************************
122 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
124 pprTopBind pe (NonRec binder expr)
125 = ppr_binding_pe pe (binder,expr) $$ text ""
127 pprTopBind pe (Rec binds)
128 = vcat [ptext SLIT("Rec {"),
129 vcat (map (ppr_binding_pe pe) binds),
130 ptext SLIT("end Rec }"),
135 ppr_bind :: PprEnv b -> Bind b -> SDoc
137 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
138 ppr_bind pe (Rec binds) = vcat (map pp binds)
140 pp bind = ppr_binding_pe pe bind <> semi
142 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
143 ppr_binding_pe pe (val_bdr, expr)
144 = sep [pBndr pe LetBind val_bdr,
145 nest 2 (equals <+> ppr_noparend_expr pe expr)]
149 ppr_parend_expr pe expr = ppr_expr parens pe expr
150 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
152 noParens :: SDoc -> SDoc
157 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
158 -- The function adds parens in context that need
159 -- an atomic value (e.g. function args)
161 ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
163 ppr_expr add_par pe (Var name) = pOcc pe name
164 ppr_expr add_par pe (Lit lit) = ppr lit
166 ppr_expr add_par pe expr@(Lam _ _)
168 (bndrs, body) = collectBinders expr
171 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
172 4 (ppr_noparend_expr pe body)
174 ppr_expr add_par pe expr@(App fun arg)
175 = case collectArgs expr of { (fun, args) ->
177 pp_args = sep (map (ppr_arg pe) args)
178 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
179 pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
182 Var f -> case isDataConId_maybe f of
183 -- Notice that we print the *worker*
184 -- for tuples in paren'd format.
185 Just dc | saturated && isTupleCon dc -> parens pp_tup_args
186 | saturated && isUnboxedTupleCon dc -> text "(#" <+> pp_tup_args <+> text "#)"
187 other -> add_par (hang (pOcc pe f) 4 pp_args)
189 saturated = length val_args == idArity f
191 other -> add_par (hang (ppr_parend_expr pe fun) 4 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 4 (sep (punctuate semi (map ppr_alt alts))),
216 ppr_bndr = pBndr pe CaseBind
218 ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
219 4 (ppr_noparend_expr pe rhs)
221 -- special cases: let ... in let ...
222 -- ("disgusting" SLPJ)
224 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
227 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
228 nest 2 (ppr_noparend_expr pe rhs),
230 ppr_noparend_expr pe body ]
232 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
234 (hang (ptext SLIT("let {"))
235 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
236 4 (ppr_noparend_expr pe rhs),
239 ppr_noparend_expr pe expr)
241 -- general case (recursive case, too)
242 ppr_expr add_par pe (Let bind expr)
244 sep [hang (ptext keyword) 2 (ppr_bind pe bind),
245 hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
247 keyword = case bind of
248 Rec _ -> SLIT("__letrec {")
249 NonRec _ _ -> SLIT("let {")
251 ppr_expr add_par pe (Note (SCC cc) expr)
252 = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
255 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
257 getPprStyle $ \ sty ->
258 if debugStyle sty && not (ifaceStyle sty) then
259 sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
260 ppr_parend_expr pe expr]
262 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
263 ppr_parend_expr pe expr]
265 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
267 sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
268 ppr_parend_expr pe expr]
271 ppr_expr add_par pe (Note InlineCall expr)
272 = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
274 ppr_expr add_par pe (Note InlineMe expr)
275 = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
277 ppr_expr add_par pe (Note (TermUsg u) expr)
278 = getPprStyle $ \ sty ->
279 if ifaceStyle sty then
280 ppr_expr add_par pe expr
282 add_par (ppr u <+> ppr_noparend_expr pe expr)
284 ppr_case_pat pe con@(DataAlt dc) args
286 = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
287 | isUnboxedTupleCon dc
288 = hsep [text "(# " <>
289 hsep (punctuate comma (map ppr_bndr args)) <>
293 ppr_bndr = pBndr pe CaseBind
295 ppr_case_pat pe con args
296 = ppr con <+> hsep (map ppr_bndr args) <+> arrow
298 ppr_bndr = pBndr pe CaseBind
300 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
301 ppr_arg pe expr = ppr_parend_expr pe expr
303 arrow = ptext SLIT("->")
306 Other printing bits-and-bobs used with the general @pprCoreBinding@
307 and @pprCoreExpr@ functions.
310 -- Used for printing dump info
311 pprCoreBinder LetBind binder
312 = vcat [sig, pragmas, ppr binder]
314 sig = pprTypedBinder binder
315 pragmas = ppIdInfo (idInfo binder)
317 -- Lambda bound type variables are preceded by "@"
318 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
320 -- Case bound things don't get a signature or a herald
321 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
323 -- Used for printing interface-file unfoldings
324 pprIfaceBinder CaseBind binder = pprUntypedBinder binder
325 pprIfaceBinder other binder = pprTypedBinder binder
327 pprUntypedBinder binder
328 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
329 | otherwise = pprIdBndr binder
331 pprTypedBinder binder
332 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
333 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
334 -- The space before the :: is important; it helps the lexer
335 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
337 -- It's important that the type is parenthesised too, at least when
338 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
340 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
341 pprIdBndr id = ppr id <+>
342 (megaSeqIdInfo (idInfo id) `seq`
343 -- Useful for poking on black holes
344 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
345 ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
350 ppIdInfo :: IdInfo -> SDoc
353 ppFlavourInfo (flavourInfo info),
356 ppWorkerInfo (workerInfo info),
361 -- Inline pragma, occ, demand, lbvar info
362 -- printed out with all binders (when debug is on);
363 -- see PprCore.pprIdBndr
367 s = strictnessInfo info
376 pprCoreRules :: Id -> CoreRules -> SDoc
377 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
379 pprIfaceCoreRules :: CoreRules -> SDoc
380 pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
382 pprCoreRule :: Maybe Id -> CoreRule -> SDoc
383 pprCoreRule maybe_fn (BuiltinRule _)
384 = ifPprDebug (ptext SLIT("A built in rule"))
386 pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
387 = doubleQuotes (ptext name) <+>
389 ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
390 nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
391 nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
394 pp_fn = case maybe_fn of
396 Nothing -> empty -- Interface file