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, pprIdBndr,
14 pprCoreRules, pprCoreRule
17 #include "HsVersions.h"
20 import CostCentre ( pprCostCentreCore )
21 import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, getIdOccInfo, Id )
22 import Var ( isTyVar )
23 import IdInfo ( IdInfo,
24 arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
25 demandInfo, updateInfo, ppUpdateInfo, specInfo,
26 strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
27 cprInfo, ppCprInfo, lbvarInfo,
28 workerInfo, ppWorkerInfo
30 import Const ( Con(..), DataCon )
31 import DataCon ( isTupleCon, isUnboxedTupleCon )
32 import PprType ( pprParendType, pprTyVarBndr )
37 %************************************************************************
39 \subsection{Public interfaces for Core printing (excluding instances)}
41 %************************************************************************
43 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
44 function for ``major'' val_bdrs (those next to equal signs :-),
45 ``minor'' ones (lambda-bound, case-bound), and bindees. They would
46 usually be called through some intermediary.
48 The binder/occ printers take the default ``homogenized'' (see
49 @PprEnv@...) @Doc@ and the binder/occ. They can either use the
50 homogenized one, or they can ignore it completely. In other words,
51 the things passed in act as ``hooks'', getting the last word on how to
54 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
56 Un-annotated core dumps
57 ~~~~~~~~~~~~~~~~~~~~~~~
59 pprCoreBindings :: [CoreBind] -> SDoc
60 pprCoreBinding :: CoreBind -> SDoc
61 pprCoreExpr :: CoreExpr -> SDoc
62 pprParendExpr :: CoreExpr -> SDoc
64 pprCoreBindings = pprTopBinds pprCoreEnv
65 pprCoreBinding = pprTopBind pprCoreEnv
66 pprCoreExpr = ppr_expr pprCoreEnv
67 pprParendExpr = ppr_parend_expr pprCoreEnv
69 pprCoreEnv = initCoreEnv pprCoreBinder
72 Printer for unfoldings in interfaces
73 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
75 pprIfaceUnfolding :: CoreExpr -> SDoc
76 pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
77 -- Notice that it's parenthesised
79 pprIfaceArg = ppr_arg pprIfaceEnv
81 pprIfaceEnv = initCoreEnv pprIfaceBinder
85 instance Outputable b => Outputable (Bind b) where
86 ppr bind = ppr_bind pprGenericEnv bind
88 instance Outputable b => Outputable (Expr b) where
89 ppr expr = ppr_expr pprGenericEnv expr
91 pprGenericEnv :: Outputable b => PprEnv b
92 pprGenericEnv = initCoreEnv (\site -> ppr)
95 %************************************************************************
97 \subsection{Instance declarations for Core printing}
99 %************************************************************************
105 (Just ppr) -- Constants
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 = sep [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_expr pe expr)]
149 ppr_parend_expr pe expr
150 | no_parens = ppr_expr pe expr
151 | otherwise = parens (ppr_expr pe expr)
153 no_parens = case expr of
156 Con (DataCon dc) _ -> isTupleCon dc
161 ppr_expr :: PprEnv b -> Expr b -> SDoc
163 ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd
165 ppr_expr pe (Var name) = pOcc pe name
167 ppr_expr pe (Con con [])
168 = ppr con -- Nullary constructors too
170 ppr_expr pe (Con (DataCon dc) args)
171 -- Drop the type arguments and print in (a,b,c) notation
173 = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
174 | isUnboxedTupleCon dc
176 hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
179 ppr_expr pe (Con con args)
180 = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
182 ppr_expr pe expr@(Lam _ _)
184 (bndrs, body) = collectBinders expr
186 hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
189 ppr_expr pe expr@(App fun arg)
191 (final_fun, final_args) = go fun [arg]
192 go (App fun arg) args_so_far = go fun (arg:args_so_far)
193 go fun args_so_far = (fun, args_so_far)
195 hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
197 ppr_expr pe (Case expr var [(con,args,rhs)])
198 = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
199 hsep [ptext SLIT("of"),
202 ppr_case_pat pe con args
208 ppr_bndr = pBndr pe CaseBind
210 ppr_expr pe (Case expr var alts)
211 = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
212 ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
213 nest 4 (sep (punctuate semi (map ppr_alt alts))),
217 ppr_bndr = pBndr pe CaseBind
219 ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
222 -- special cases: let ... in let ...
223 -- ("disgusting" SLPJ)
225 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
227 hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
228 nest 2 (ppr_expr pe rhs),
232 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
233 = hang (ptext SLIT("let {"))
234 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
240 -- general case (recursive case, too)
241 ppr_expr pe (Let bind expr)
242 = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
243 hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
245 keyword = case bind of
246 Rec _ -> SLIT("__letrec {")
247 NonRec _ _ -> SLIT("let {")
249 ppr_expr pe (Note (SCC cc) expr)
250 = sep [pSCC pe cc, ppr_expr pe expr]
253 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
254 = getPprStyle $ \ sty ->
255 if debugStyle sty && not (ifaceStyle sty) then
256 sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
257 ppr_parend_expr pe expr]
259 sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
260 ppr_parend_expr pe expr]
262 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
263 = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
264 ppr_parend_expr pe expr]
267 ppr_expr pe (Note InlineCall expr)
268 = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr
270 ppr_expr pe (Note InlineMe expr)
271 = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
273 ppr_expr pe (Note (TermUsg u) expr)
275 if ifaceStyle sty then
278 (ppr u <+> ppr_expr pe expr) sty
280 ppr_case_pat pe con@(DataCon dc) args
282 = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
283 | isUnboxedTupleCon dc
284 = hsep [text "(# " <>
285 hsep (punctuate comma (map ppr_bndr args)) <>
289 ppr_bndr = pBndr pe CaseBind
291 ppr_case_pat pe con args
292 = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
294 ppr_bndr = pBndr pe CaseBind
296 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
297 ppr_arg pe expr = ppr_parend_expr pe expr
299 arrow = ptext SLIT("->")
302 Other printing bits-and-bobs used with the general @pprCoreBinding@
303 and @pprCoreExpr@ functions.
306 -- Used for printing dump info
307 pprCoreBinder LetBind binder
308 = vcat [sig, pragmas, ppr binder]
310 sig = pprTypedBinder binder
311 pragmas = ppIdInfo (idInfo binder)
313 -- Lambda bound type variables are preceded by "@"
314 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
316 -- Case bound things don't get a signature or a herald
317 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
319 -- Used for printing interface-file unfoldings
320 pprIfaceBinder CaseBind binder = pprUntypedBinder binder
321 pprIfaceBinder other binder = pprTypedBinder binder
323 pprUntypedBinder binder
324 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
325 | otherwise = pprIdBndr binder
327 pprTypedBinder binder
328 | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
329 | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
330 -- The space before the :: is important; it helps the lexer
331 -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
333 -- It's important that the type is parenthesised too, at least when
334 -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
336 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
337 pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdOccInfo id) <+>
338 ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
343 ppIdInfo :: IdInfo -> SDoc
346 ppFlavourInfo (flavourInfo info),
349 ppWorkerInfo (workerInfo info),
354 ppr (lbvarInfo info),
356 -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
361 s = strictnessInfo info
370 pprCoreRules :: Id -> CoreRules -> SDoc
371 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
373 pprIfaceCoreRules :: CoreRules -> SDoc
374 pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
376 pprCoreRule :: Maybe Id -> CoreRule -> SDoc
377 pprCoreRule maybe_fn (BuiltinRule _)
378 = ifPprDebug (ptext SLIT("A built in rule"))
380 pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
381 = doubleQuotes (ptext name) <+>
383 ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
384 nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
385 nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
388 pp_fn = case maybe_fn of
390 Nothing -> empty -- Interface file