ghc/compiler/coreSyn/PprCore.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[PprCore]{Printing of Core syntax, including for interfaces}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 \begin{code}
  11 module PprCore (
  12         pprCoreExpr, pprIfaceUnfolding,
  13         pprCoreBinding, pprCoreBindings,
  14         pprGenericBindings
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CoreSyn
  20 import CostCentre       ( showCostCentre )
  21 import Id               ( idType, idInfo, isTupleCon,
  22                           GenId{-instances-}, Id
  23                         )
  24 import IdInfo           ( ppIdInfo )
  25 import Outputable       -- quite a few things
  26 import PprEnv
  27 import PprType          ( pprParendType, pprTyVarBndr )
  28
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection{Public interfaces for Core printing (excluding instances)}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  38 function for ``major'' val_bdrs (those next to equal signs :-),
  39 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  40 usually be called through some intermediary.
  41
  42 The binder/occ printers take the default ``homogenized'' (see
  43 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  44 homogenized one, or they can ignore it completely.  In other words,
  45 the things passed in act as ``hooks'', getting the last word on how to
  46 print something.
  47
  48 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  49
  50 Un-annotated core dumps
  51 ~~~~~~~~~~~~~~~~~~~~~~~
  52 \begin{code}
  53 pprCoreBindings :: [CoreBinding] -> SDoc
  54 pprCoreBinding  :: CoreBinding   -> SDoc
  55 pprCoreExpr     :: CoreExpr      -> SDoc
  56
  57 pprCoreBindings = pprTopBinds pprCoreEnv
  58 pprCoreBinding  = pprTopBind pprCoreEnv
  59 pprCoreExpr     = ppr_expr pprCoreEnv
  60
  61 pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
  62 \end{code}
  63
  64 Printer for unfoldings in interfaces
  65 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  66 \begin{code}
  67 pprIfaceUnfolding :: CoreExpr -> SDoc
  68 pprIfaceUnfolding = ppr_expr pprIfaceEnv
  69
  70 pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder  ppr
  71 \end{code}
  72
  73 Generic Core (possibly annotated binders etc)
  74 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  75 \begin{code}
  76 pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
  77 pprGenericBindings = pprTopBinds pprGenericEnv
  78
  79 pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
  80 pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
  81
  82 pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
  83 pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
  84
  85 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
  86     ppr bind = ppr_bind pprGenericEnv bind
  87
  88 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
  89     ppr expr = ppr_expr pprGenericEnv expr
  90
  91 instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
  92     ppr arg = ppr_arg pprGenericArgEnv arg
  93
  94 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
  95     ppr alts = ppr_alts pprGenericEnv alts
  96
  97 instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
  98     ppr deflt  = ppr_default pprGenericEnv deflt
  99 \end{code}
 100
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection{Instance declarations for Core printing}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108
 109 \begin{code}
 110 init_ppr_env tvbndr pbdr pocc
 111   = initPprEnv
 112         (Just ppr) -- literals
 113         (Just ppr)              -- data cons
 114         (Just ppr_prim)         -- primops
 115         (Just (\ cc -> text (showCostCentre True cc)))
 116
 117         (Just tvbndr)           -- tyvar binders
 118         (Just ppr)              -- tyvar occs
 119         (Just pprParendType)    -- types
 120
 121         (Just pbdr) (Just pocc) -- value vars
 122   where
 123
 124         -- We add a "!" to distinguish Primitive applications from ordinary applications.
 125         -- But not when printing for interfaces, where they are treated
 126         -- as ordinary applications
 127     ppr_prim prim = getPprStyle (\sty -> if ifaceStyle sty then
 128                                             ppr prim
 129                                          else
 130                                             ppr prim <> char '!')
 131
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsection{The guts}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 \begin{code}
 141 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
 142
 143 pprTopBind pe (NonRec binder expr)
 144  = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
 145
 146 pprTopBind pe (Rec binds)
 147   = vcat [ptext SLIT("Rec {"),
 148           vcat (map (ppr_binding_pe pe) binds),
 149           ptext SLIT("end Rec }"),
 150           text ""]
 151 \end{code}
 152
 153 \begin{code}
 154 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 155 ppr_bind pe (Rec binds)           = vcat (map pp binds)
 156                                   where
 157                                     pp bind = ppr_binding_pe pe bind <> semi
 158
 159 ppr_binding_pe pe (val_bdr, expr)
 160   = sep [pValBndr pe LetBind val_bdr,
 161          nest 2 (equals <+> ppr_expr pe expr)]
 162 \end{code}
 163
 164 \begin{code}
 165 ppr_parend_expr pe expr
 166   = let
 167         parenify
 168           = case expr of
 169               Var _ -> id       -- leave unchanged
 170               Lit _ -> id
 171               _     -> parens   -- wraps in parens
 172     in
 173     parenify (ppr_expr pe expr)
 174 \end{code}
 175
 176 \begin{code}
 177 ppr_expr pe (Var name)   = pOcc pe name
 178 ppr_expr pe (Lit lit)    = pLit pe lit
 179
 180 ppr_expr pe (Con con args)
 181   = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
 182
 183 ppr_expr pe (Prim prim args)
 184   = pPrim pe prim <+> (sep (map (ppr_arg pe) args))
 185
 186 ppr_expr pe expr@(Lam _ _)
 187   = let
 188         (tyvars, vars, body) = collectBinders expr
 189     in
 190     hang (hsep [pp_vars SLIT("_/\\_") (pTyVarB  pe) tyvars,
 191                 pp_vars SLIT("\\")    (pValBndr pe LambdaBind) vars])
 192          4 (ppr_expr pe body)
 193   where
 194     pp_vars lam pp [] = empty
 195     pp_vars lam pp vs
 196       = hsep [ptext lam, vcat (map pp vs), ptext SLIT("->")]
 197
 198 ppr_expr pe expr@(App fun arg)
 199   = let
 200         (final_fun, final_args)      = go fun [arg]
 201         go (App fun arg) args_so_far = go fun (arg:args_so_far)
 202         go fun           args_so_far = (fun, args_so_far)
 203     in
 204     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 205
 206 ppr_expr pe (Case expr alts)
 207   | only_one_alt alts
 208     -- johan thinks that single case patterns should be on same line as case,
 209     -- and no indent; all sane persons agree with him.
 210   = let
 211         ppr_bndr = pValBndr pe CaseBind
 212
 213         ppr_alt (AlgAlts  [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
 214         ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (ppr_bndr n) ppr_arrow
 215         ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l)         ppr_arrow
 216         ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
 217           = hsep [pCon pe con,
 218                    hsep (map ppr_bndr params),
 219                    ppr_arrow]
 220
 221         ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
 222         ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
 223         ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
 224         ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
 225
 226
 227         ppr_arrow = ptext SLIT(" ->")
 228     in
 229     sep
 230     [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
 231             (<>) (ppr_rhs alts) (text ";}")]
 232
 233   | otherwise -- default "case" printing
 234   = sep
 235     [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
 236      nest 2 (ppr_alts pe alts),
 237      text "}"]
 238   where
 239     pp_keyword = case alts of
 240                   AlgAlts _ _  -> ptext SLIT("case")
 241                   PrimAlts _ _ -> ptext SLIT("case#")
 242
 243 -- special cases: let ... in let ...
 244 -- ("disgusting" SLPJ)
 245
 246 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 247   = vcat [
 248       hsep [ptext SLIT("let {"), pValBndr pe LetBind val_bdr, equals],
 249       nest 2 (ppr_expr pe rhs),
 250       ptext SLIT("} in"),
 251       ppr_expr pe body ]
 252
 253 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 254   = ($$)
 255       (hang (ptext SLIT("let {"))
 256             2 (hsep [hang (hsep [pValBndr pe LetBind val_bdr, equals])
 257                            4 (ppr_expr pe rhs),
 258        ptext SLIT("} in")]))
 259       (ppr_expr pe expr)
 260
 261 -- general case (recursive case, too)
 262 ppr_expr pe (Let bind expr)
 263   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 264            hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
 265   where
 266     keyword = case bind of
 267                 Rec _      -> SLIT("_letrec_ {")
 268                 NonRec _ _ -> SLIT("let {")
 269
 270 ppr_expr pe (Note (SCC cc) expr)
 271   = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
 272          ppr_parend_expr pe expr ]
 273
 274 #ifdef DEBUG
 275 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 276  = \ sty ->
 277    if debugStyle sty && not (ifaceStyle sty) then
 278       sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty, pTy pe from_ty],
 279                   ppr_parend_expr pe expr] sty
 280    else
 281       sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
 282                   ppr_parend_expr pe expr] sty
 283 #else
 284 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 285   = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty],
 286          ppr_parend_expr pe expr]
 287 #endif
 288
 289 ppr_expr pe (Note InlineCall expr)
 290   = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
 291
 292 only_one_alt (AlgAlts []     (BindDefault _ _)) = True
 293 only_one_alt (AlgAlts (_:[])  NoDefault)        = True
 294 only_one_alt (PrimAlts []    (BindDefault _ _)) = True
 295 only_one_alt (PrimAlts (_:[]) NoDefault)        = True
 296 only_one_alt _                                  = False
 297 \end{code}
 298
 299 \begin{code}
 300 ppr_alts pe (AlgAlts alts deflt)
 301   = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
 302   where
 303     ppr_arrow = ptext SLIT("->")
 304     ppr_bndr = pValBndr pe CaseBind
 305
 306     ppr_alt (con, params, expr)
 307       = hang (if isTupleCon con then
 308                     hsep [parens (hsep (punctuate comma (map ppr_bndr params))),
 309                           ppr_arrow]
 310                 else
 311                     hsep [pCon pe con,
 312                           hsep (map ppr_bndr params),
 313                            ppr_arrow]
 314                )
 315              4 (ppr_expr pe expr <> semi)
 316
 317 ppr_alts pe (PrimAlts alts deflt)
 318   = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
 319   where
 320     ppr_alt (lit, expr)
 321       = hang (hsep [pLit pe lit, ptext SLIT("->")])
 322              4 (ppr_expr pe expr <> semi)
 323 \end{code}
 324
 325 \begin{code}
 326 ppr_default pe NoDefault = empty
 327
 328 ppr_default pe (BindDefault val_bdr expr)
 329   = hang (hsep [pValBndr pe CaseBind val_bdr, ptext SLIT("->")])
 330          4 (ppr_expr pe expr <> semi)
 331 \end{code}
 332
 333 \begin{code}
 334 ppr_arg pe (LitArg   lit) = pLit pe lit
 335 ppr_arg pe (VarArg   v)   = pOcc pe v
 336 ppr_arg pe (TyArg    ty)  = ptext SLIT("_@_ ") <> pTy pe ty
 337 \end{code}
 338
 339 Other printing bits-and-bobs used with the general @pprCoreBinding@
 340 and @pprCoreExpr@ functions.
 341
 342 \begin{code}
 343 -- Used for printing dump info
 344 pprCoreBinder LetBind binder
 345   = vcat [sig, pragmas, ppr binder]
 346   where
 347     sig     = pprTypedBinder binder
 348     pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
 349
 350 pprCoreBinder LambdaBind binder = pprTypedBinder binder
 351 pprCoreBinder CaseBind   binder = ppr binder
 352
 353
 354 -- Used for printing interface-file unfoldings
 355 pprIfaceBinder CaseBind binder = ppr binder
 356 pprIfaceBinder other    binder = pprTypedBinder binder
 357
 358 pprTypedBinder binder
 359   = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
 360         -- The space before the :: is important; it helps the lexer
 361         -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
 362         --
 363         -- It's important that the type is parenthesised too, at least when
 364         -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 365 \end{code}