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 pprCoreExpr 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 (CoreNote s) expr)
218 sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
221 pprCoreAlt (con, args, rhs)
222 = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
224 ppr_case_pat con@(DataAlt dc) args
226 = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
228 ppr_bndr = pprBndr CaseBind
231 ppr_case_pat con args
232 = ppr con <+> sep (map ppr_bndr args) <+> arrow
234 ppr_bndr = pprBndr CaseBind
236 pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
237 pprArg expr = pprParendExpr expr
240 Other printing bits-and-bobs used with the general @pprCoreBinding@
241 and @pprCoreExpr@ functions.
244 instance OutputableBndr Var where
245 pprBndr = pprCoreBinder
247 pprCoreBinder :: BindingSite -> Var -> SDoc
248 pprCoreBinder LetBind binder
249 = vcat [sig, pprIdDetails binder, pragmas]
251 sig = pprTypedBinder binder
252 pragmas = ppIdInfo binder (idInfo binder)
254 -- Lambda bound type variables are preceded by "@"
255 pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
257 -- Case bound things don't get a signature or a herald, unless we have debug on
258 pprCoreBinder CaseBind bndr
259 = getPprStyle $ \ sty ->
260 if debugStyle sty then
261 parens (pprTypedBinder bndr)
263 pprUntypedBinder bndr
265 pprUntypedBinder binder
266 | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
267 | otherwise = pprIdBndr binder
269 pprTypedBinder binder
270 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
271 | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
273 pprTyVarBndr :: TyVar -> SDoc
275 = getPprStyle $ \ sty ->
276 if debugStyle sty then
277 hsep [ppr tyvar, dcolon, pprParendKind kind]
278 -- See comments with ppDcolon in PprCore.lhs
282 kind = tyVarKind tyvar
284 -- pprIdBndr does *not* print the type
285 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
286 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
289 = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
291 prag_info = inlinePragInfo info
292 occ_info = occInfo info
293 dmd_info = newDemandInfo info
294 lbv_info = lbvarInfo info
296 no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
297 (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
298 hasNoLBVarInfo lbv_info
300 doc | no_info = empty
302 = brackets $ hsep [ppr prag_info, ppr occ_info,
303 ppr dmd_info, ppr lbv_info
304 #ifdef OLD_STRICTNESS
305 , ppr (demandInfo id)
312 pprIdDetails :: Id -> SDoc
313 pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
314 | isExportedId id = ptext SLIT("[Exported]")
317 ppIdInfo :: Id -> IdInfo -> SDoc
320 vcat [ ppArityInfo a,
321 ppWorkerInfo (workerInfo info),
322 ppCafInfo (cafInfo info),
323 #ifdef OLD_STRICTNESS
327 pprNewStrictness (newStrictnessInfo info),
328 if null rules then empty
329 else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
330 -- Inline pragma, occ, demand, lbvar info
331 -- printed out with all binders (when debug is on);
332 -- see PprCore.pprIdBndr
336 #ifdef OLD_STRICTNESS
337 s = strictnessInfo info
340 rules = specInfoRules (specInfo info)
345 instance Outputable CoreRule where
348 pprRules :: [CoreRule] -> SDoc
349 pprRules rules = vcat (map pprRule rules)
351 pprRule :: CoreRule -> SDoc
352 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
353 = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
355 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
356 ru_bndrs = tpl_vars, ru_args = tpl_args,
358 = hang (doubleQuotes (ftext name) <+> ppr act)
359 4 (sep [ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
360 nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
361 nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)