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