2 % (c) The University of Glasgow 2006
3 % (c) The AQUA Project, Glasgow University, 1996-1998
6 Printing of Core syntax
10 pprCoreExpr, pprParendExpr,
11 pprCoreBinding, pprCoreBindings, pprCoreAlt,
15 #include "HsVersions.h"
39 %************************************************************************
41 \subsection{Public interfaces for Core printing (excluding instances)}
43 %************************************************************************
45 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
48 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
49 pprCoreBinding :: OutputableBndr b => Bind b -> SDoc
50 pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
51 pprParendExpr :: OutputableBndr b => Expr b -> SDoc
53 pprCoreBindings = pprTopBinds
54 pprCoreBinding = pprTopBind
56 instance OutputableBndr b => Outputable (Bind b) where
57 ppr bind = ppr_bind bind
59 instance OutputableBndr b => Outputable (Expr b) where
60 ppr expr = pprCoreExpr expr
64 %************************************************************************
68 %************************************************************************
71 pprTopBinds binds = vcat (map pprTopBind binds)
73 pprTopBind (NonRec binder expr)
74 = ppr_binding (binder,expr) $$ text ""
76 pprTopBind (Rec binds)
77 = vcat [ptext SLIT("Rec {"),
78 vcat (map ppr_binding binds),
79 ptext SLIT("end Rec }"),
84 ppr_bind :: OutputableBndr b => Bind b -> SDoc
86 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
87 ppr_bind (Rec binds) = vcat (map pp binds)
89 pp bind = ppr_binding bind <> semi
91 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
92 ppr_binding (val_bdr, expr)
93 = pprBndr LetBind val_bdr $$
94 hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
98 pprParendExpr expr = ppr_expr parens expr
99 pprCoreExpr expr = ppr_expr noParens expr
101 noParens :: SDoc -> SDoc
106 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
107 -- The function adds parens in context that need
108 -- an atomic value (e.g. function args)
110 ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
112 ppr_expr add_par (Var name) = ppr name
113 ppr_expr add_par (Lit lit) = ppr lit
115 ppr_expr add_par (Cast expr co)
117 sep [pprParendExpr expr,
118 ptext SLIT("`cast`") <+> parens (pprCo co)]
120 pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
123 ppr_expr add_par expr@(Lam _ _)
125 (bndrs, body) = collectBinders expr
128 hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
131 ppr_expr add_par expr@(App fun arg)
132 = case collectArgs expr of { (fun, args) ->
134 pp_args = sep (map pprArg args)
135 val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
136 pp_tup_args = sep (punctuate comma (map pprArg val_args))
139 Var f -> case isDataConWorkId_maybe f of
140 -- Notice that we print the *worker*
141 -- for tuples in paren'd format.
142 Just dc | saturated && isTupleTyCon tc
143 -> tupleParens (tupleTyConBoxity tc) pp_tup_args
146 saturated = val_args `lengthIs` idArity f
148 other -> add_par (hang (ppr f) 2 pp_args)
150 other -> add_par (hang (pprParendExpr fun) 2 pp_args)
153 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
155 sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
156 ifPprDebug (braces (ppr ty)),
157 sep [ptext SLIT("of") <+> ppr_bndr var,
158 char '{' <+> ppr_case_pat con args]
164 ppr_bndr = pprBndr CaseBind
166 ppr_expr add_par (Case expr var ty alts)
168 sep [sep [ptext SLIT("case")
170 <+> ifPprDebug (braces (ppr ty)),
171 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
172 nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
176 ppr_bndr = pprBndr CaseBind
179 -- special cases: let ... in let ...
180 -- ("disgusting" SLPJ)
183 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
186 hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
187 nest 2 (pprCoreExpr rhs),
192 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
194 (hang (ptext SLIT("let {"))
195 2 (hsep [ppr_binding (val_bdr,rhs),
200 -- general case (recursive case, too)
201 ppr_expr add_par (Let bind expr)
203 sep [hang (ptext keyword) 2 (ppr_bind bind),
204 hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
206 keyword = case bind of
207 Rec _ -> SLIT("__letrec {")
208 NonRec _ _ -> SLIT("let {")
210 ppr_expr add_par (Note (SCC cc) expr)
211 = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
213 ppr_expr add_par (Note InlineMe expr)
214 = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
216 ppr_expr add_par (Note (TickBox mod n) expr)
218 sep [sep [ptext SLIT("__tick_box"),
223 ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
225 sep [sep [ptext SLIT("__binary_tick_box"),
231 ppr_expr add_par (Note (CoreNote s) expr)
233 sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
236 pprCoreAlt (con, args, rhs)
237 = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
239 ppr_case_pat con@(DataAlt dc) args
241 = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
243 ppr_bndr = pprBndr CaseBind
246 ppr_case_pat con args
247 = ppr con <+> sep (map ppr_bndr args) <+> arrow
249 ppr_bndr = pprBndr CaseBind
251 pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
252 pprArg expr = pprParendExpr expr
255 Other printing bits-and-bobs used with the general @pprCoreBinding@
256 and @pprCoreExpr@ functions.
259 instance OutputableBndr Var where
260 pprBndr = pprCoreBinder
262 pprCoreBinder :: BindingSite -> Var -> SDoc
263 pprCoreBinder LetBind binder
264 = vcat [sig, pprIdDetails binder, pragmas]
266 sig = pprTypedBinder binder
267 pragmas = ppIdInfo binder (idInfo binder)
269 -- Lambda bound type variables are preceded by "@"
270 pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
272 -- Case bound things don't get a signature or a herald, unless we have debug on
273 pprCoreBinder CaseBind bndr
274 = getPprStyle $ \ sty ->
275 if debugStyle sty then
276 parens (pprTypedBinder bndr)
278 pprUntypedBinder bndr
280 pprUntypedBinder binder
281 | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
282 | otherwise = pprIdBndr binder
284 pprTypedBinder binder
285 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
286 | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
288 pprTyVarBndr :: TyVar -> SDoc
290 = getPprStyle $ \ sty ->
291 if debugStyle sty then
292 hsep [ppr tyvar, dcolon, pprParendKind kind]
293 -- See comments with ppDcolon in PprCore.lhs
297 kind = tyVarKind tyvar
299 -- pprIdBndr does *not* print the type
300 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
301 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
304 = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
306 prag_info = inlinePragInfo info
307 occ_info = occInfo info
308 dmd_info = newDemandInfo info
309 lbv_info = lbvarInfo info
311 no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
312 (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
313 hasNoLBVarInfo lbv_info
315 doc | no_info = empty
317 = brackets $ hsep [ppr prag_info, ppr occ_info,
318 ppr dmd_info, ppr lbv_info
319 #ifdef OLD_STRICTNESS
320 , ppr (demandInfo id)
327 pprIdDetails :: Id -> SDoc
328 pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
329 | isExportedId id = ptext SLIT("[Exported]")
332 ppIdInfo :: Id -> IdInfo -> SDoc
335 vcat [ ppArityInfo a,
336 ppWorkerInfo (workerInfo info),
337 ppCafInfo (cafInfo info),
338 #ifdef OLD_STRICTNESS
342 pprNewStrictness (newStrictnessInfo info),
343 if null rules then empty
344 else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
345 -- Inline pragma, occ, demand, lbvar info
346 -- printed out with all binders (when debug is on);
347 -- see PprCore.pprIdBndr
351 #ifdef OLD_STRICTNESS
352 s = strictnessInfo info
355 rules = specInfoRules (specInfo info)
360 instance Outputable CoreRule where
363 pprRules :: [CoreRule] -> SDoc
364 pprRules rules = vcat (map pprRule rules)
366 pprRule :: CoreRule -> SDoc
367 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
368 = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
370 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
371 ru_bndrs = tpl_vars, ru_args = tpl_args,
373 = hang (doubleQuotes (ftext name) <+> ppr act)
374 4 (sep [ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
375 nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
376 nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)