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