[project @ 2001-04-09 23:22:42 by lewie]
[ghc-hetmet.git] / ghc / compiler / coreSyn / PprCore.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1996-1998
3 %
4 %************************************************************************
5 %*                                                                      *
6 \section[PprCore]{Printing of Core syntax, including for interfaces}
7 %*                                                                      *
8 %************************************************************************
9
10 \begin{code}
11 module PprCore (
12         pprCoreExpr, pprParendExpr,
13         pprCoreBinding, pprCoreBindings, pprIdBndr,
14         pprCoreBinding, pprCoreBindings, pprCoreAlt,
15         pprCoreRules, pprCoreRule, pprIdCoreRule
16     ) where
17
18 #include "HsVersions.h"
19
20 import CoreSyn
21 import CostCentre       ( pprCostCentreCore )
22 import Id               ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
23                           idInfo, idInlinePragma, idDemandInfo, idOccInfo,
24                           globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
25                         )
26 import Var              ( isTyVar )
27 import IdInfo           ( IdInfo, megaSeqIdInfo, 
28                           arityInfo, ppArityInfo, 
29                           specInfo, cprInfo, ppCprInfo, 
30                           strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo,
31                           cprInfo, ppCprInfo, 
32                           workerInfo, ppWorkerInfo,
33                           tyGenInfo, ppTyGenInfo
34                         )
35 import DataCon          ( dataConTyCon )
36 import TyCon            ( tupleTyConBoxity, isTupleTyCon )
37 import PprType          ( pprParendType, pprTyVarBndr )
38 import BasicTypes       ( tupleParens )
39 import PprEnv
40 import Outputable
41 \end{code}
42
43 %************************************************************************
44 %*                                                                      *
45 \subsection{Public interfaces for Core printing (excluding instances)}
46 %*                                                                      *
47 %************************************************************************
48
49 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
50 function for ``major'' val_bdrs (those next to equal signs :-),
51 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
52 usually be called through some intermediary.
53
54 The binder/occ printers take the default ``homogenized'' (see
55 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
56 homogenized one, or they can ignore it completely.  In other words,
57 the things passed in act as ``hooks'', getting the last word on how to
58 print something.
59
60 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
61
62 Un-annotated core dumps
63 ~~~~~~~~~~~~~~~~~~~~~~~
64 \begin{code}
65 pprCoreBindings :: [CoreBind] -> SDoc
66 pprCoreBinding  :: CoreBind   -> SDoc
67 pprCoreExpr     :: CoreExpr   -> SDoc
68 pprParendExpr   :: CoreExpr   -> SDoc
69
70 pprCoreBindings = pprTopBinds pprCoreEnv
71 pprCoreBinding  = pprTopBind pprCoreEnv
72 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
73 pprParendExpr   = ppr_parend_expr   pprCoreEnv
74 pprArg          = ppr_arg pprCoreEnv
75 pprCoreAlt      = ppr_alt pprCoreEnv
76
77 pprCoreEnv = initCoreEnv pprCoreBinder
78 \end{code}
79
80 Printer for unfoldings in interfaces
81 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
82 \begin{code}
83 instance Outputable b => Outputable (Bind b) where
84     ppr bind = ppr_bind pprGenericEnv bind
85
86 instance Outputable b => Outputable (Expr b) where
87     ppr expr = ppr_noparend_expr pprGenericEnv expr
88
89 pprGenericEnv :: Outputable b => PprEnv b
90 pprGenericEnv = initCoreEnv (\site -> ppr)
91 \end{code}
92
93 %************************************************************************
94 %*                                                                      *
95 \subsection{Instance declarations for Core printing}
96 %*                                                                      *
97 %************************************************************************
98
99
100 \begin{code}
101 initCoreEnv pbdr
102   = initPprEnv
103         (Just pprCostCentreCore)        -- Cost centres
104
105         (Just ppr)              -- tyvar occs
106         (Just pprParendType)    -- types
107
108         (Just pbdr) (Just ppr) -- value vars
109         -- Use pprIdBndr for this last one as a debugging device.
110 \end{code}
111
112 %************************************************************************
113 %*                                                                      *
114 \subsection{The guts}
115 %*                                                                      *
116 %************************************************************************
117
118 \begin{code}
119 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
120
121 pprTopBind pe (NonRec binder expr)
122  = ppr_binding_pe pe (binder,expr) $$ text ""
123
124 pprTopBind pe (Rec binds)
125   = vcat [ptext SLIT("Rec {"),
126           vcat (map (ppr_binding_pe pe) binds),
127           ptext SLIT("end Rec }"),
128           text ""]
129 \end{code}
130
131 \begin{code}
132 ppr_bind :: PprEnv b -> Bind b -> SDoc
133
134 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
135 ppr_bind pe (Rec binds)           = vcat (map pp binds)
136                                   where
137                                     pp bind = ppr_binding_pe pe bind <> semi
138
139 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
140 ppr_binding_pe pe (val_bdr, expr)
141   = sep [pBndr pe LetBind val_bdr, 
142          nest 2 (equals <+> ppr_noparend_expr pe expr)]
143 \end{code}
144
145 \begin{code}
146 ppr_parend_expr   pe expr = ppr_expr parens pe expr
147 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
148
149 noParens :: SDoc -> SDoc
150 noParens pp = pp
151 \end{code}
152
153 \begin{code}
154 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
155         -- The function adds parens in context that need
156         -- an atomic value (e.g. function args)
157
158 ppr_expr add_par pe (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)        -- Wierd
159                    
160 ppr_expr add_par pe (Var name) = pOcc pe name
161 ppr_expr add_par pe (Lit lit)  = ppr lit
162
163 ppr_expr add_par pe expr@(Lam _ _)
164   = let
165         (bndrs, body) = collectBinders expr
166     in
167     add_par $
168     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
169          2 (ppr_noparend_expr pe body)
170
171 ppr_expr add_par pe expr@(App fun arg)
172   = case collectArgs expr of { (fun, args) -> 
173     let
174         pp_args     = sep (map (ppr_arg pe) args)
175         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
176         pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
177     in
178     case fun of
179         Var f -> case isDataConId_maybe f of
180                         -- Notice that we print the *worker*
181                         -- for tuples in paren'd format.
182                    Just dc | saturated && isTupleTyCon tc
183                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
184                            where
185                              tc        = dataConTyCon dc
186                              saturated = length val_args == idArity f
187
188                    other -> add_par (hang (pOcc pe f) 2 pp_args)
189
190         other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
191     }
192
193 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
194   = add_par $
195     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
196               hsep [ptext SLIT("of"),
197                     ppr_bndr var,
198                     char '{',
199                     ppr_case_pat pe con args
200           ]],
201          ppr_noparend_expr pe rhs,
202          char '}'
203     ]
204   where
205     ppr_bndr = pBndr pe CaseBind
206
207 ppr_expr add_par pe (Case expr var alts)
208   = add_par $
209     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
210               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
211          nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
212          char '}'
213     ]
214   where
215     ppr_bndr = pBndr pe CaseBind
216  
217
218 -- special cases: let ... in let ...
219 -- ("disgusting" SLPJ)
220
221 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
222   = add_par $
223     vcat [
224       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
225       nest 2 (ppr_noparend_expr pe rhs),
226       ptext SLIT("} in"),
227       ppr_noparend_expr pe body ]
228
229 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
230   = add_par
231     (hang (ptext SLIT("let {"))
232           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
233                            2 (ppr_noparend_expr pe rhs),
234        ptext SLIT("} in")])
235      $$
236      ppr_noparend_expr pe expr)
237
238 -- general case (recursive case, too)
239 ppr_expr add_par pe (Let bind expr)
240   = add_par $
241     sep [hang (ptext keyword) 2 (ppr_bind pe bind),
242          hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
243   where
244     keyword = case bind of
245                 Rec _      -> SLIT("__letrec {")
246                 NonRec _ _ -> SLIT("let {")
247
248 ppr_expr add_par pe (Note (SCC cc) expr)
249   = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
250
251 #ifdef DEBUG
252 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
253  = add_par $
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]
258    else
259       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
260                   ppr_parend_expr pe expr]
261 #else
262 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
263   = add_par $
264     sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
265          ppr_parend_expr pe expr]
266 #endif
267
268 ppr_expr add_par pe (Note InlineCall expr)
269   = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
270
271 ppr_expr add_par pe (Note InlineMe expr)
272   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
273
274 ppr_alt pe (con, args, rhs) 
275   = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
276
277 ppr_case_pat pe con@(DataAlt dc) args
278   | isTupleTyCon tc
279   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
280   where
281     ppr_bndr = pBndr pe CaseBind
282     tc = dataConTyCon dc
283
284 ppr_case_pat pe con args
285   = ppr con <+> hsep (map ppr_bndr args) <+> arrow
286   where
287     ppr_bndr = pBndr pe CaseBind
288
289 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
290 ppr_arg pe expr      = ppr_parend_expr pe expr
291
292 arrow = ptext SLIT("->")
293 \end{code}
294
295 Other printing bits-and-bobs used with the general @pprCoreBinding@
296 and @pprCoreExpr@ functions.
297
298 \begin{code}
299 -- Used for printing dump info
300 pprCoreBinder LetBind binder
301   = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
302   where
303     sig     = pprTypedBinder binder
304     pragmas = ppIdInfo binder (idInfo binder)
305
306 -- Lambda bound type variables are preceded by "@"
307 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
308
309 -- Case bound things don't get a signature or a herald
310 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
311
312 pprUntypedBinder binder
313   | isTyVar binder = ptext SLIT("@") <+> ppr binder     -- NB: don't print kind
314   | otherwise      = pprIdBndr binder
315
316 pprTypedBinder binder
317   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
318   | otherwise       = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
319         -- The space before the :: is important; it helps the lexer
320         -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
321         --
322         -- It's important that the type is parenthesised too, at least when
323         -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
324
325 -- pprIdBndr does *not* print the type
326 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
327 pprIdBndr id = ppr id <+> 
328                (megaSeqIdInfo (idInfo id) `seq`
329                         -- Useful for poking on black holes
330                 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> 
331                             ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
332 \end{code}
333
334
335 \begin{code}
336 pprIdDetails :: Id -> SDoc
337 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
338                 | isExportedId id   = ptext SLIT("[Exported]")
339                 | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
340                 | otherwise         = empty
341
342 ppIdInfo :: Id -> IdInfo -> SDoc
343 ppIdInfo b info
344   = hsep [  ppArityInfo a,
345             ppTyGenInfo g,
346             ppWorkerInfo (workerInfo info),
347             ppStrictnessInfo s,
348 --          pprCgInfo c,
349             ppCprInfo m,
350             pprCoreRules b p
351         -- Inline pragma, occ, demand, lbvar info
352         -- printed out with all binders (when debug is on); 
353         -- see PprCore.pprIdBndr
354         ]
355   where
356     a = arityInfo info
357     g = tyGenInfo info
358     s = strictnessInfo info
359     c = cgInfo info
360     m = cprInfo info
361     p = specInfo info
362 \end{code}
363
364
365 \begin{code}
366 pprCoreRules :: Id -> CoreRules -> SDoc
367 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
368
369 pprIdCoreRule :: IdCoreRule -> SDoc
370 pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
371
372 pprCoreRule :: SDoc -> CoreRule -> SDoc
373 pprCoreRule pp_fn (BuiltinRule _)
374   = ifPprDebug (ptext SLIT("A built in rule"))
375
376 pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
377   = doubleQuotes (ptext name) <+> 
378     sep [
379           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
380           nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
381           nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
382     ] <+> semi
383 \end{code}