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