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