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 #include "HsVersions.h"
  12
  13 module PprCore (
  14         pprCoreExpr,
  15         pprCoreBinding,
  16         pprBigCoreBinder,
  17         pprTypedCoreBinder
  18
  19         -- these are here to make the instances go in 0.26:
  20 #if __GLASGOW_HASKELL__ <= 26
  21         , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
  22         , GenCoreCaseDefault, GenCoreArg
  23 #endif
  24     ) where
  25
  26 import Ubiq{-uitous-}
  27
  28 import CoreSyn
  29 import CostCentre       ( showCostCentre )
  30 import Id               ( idType, getIdInfo, getIdStrictness,
  31                           nullIdEnv, DataCon(..), GenId{-instances-}
  32                         )
  33 import IdInfo           ( ppIdInfo, StrictnessInfo(..) )
  34 import Literal          ( Literal{-instances-} )
  35 import Outputable       -- quite a few things
  36 import PprEnv
  37 import PprType          ( GenType{-instances-}, GenTyVar{-instance-} )
  38 import PprStyle         ( PprStyle(..) )
  39 import Pretty
  40 import PrimOp           ( PrimOp{-instances-} )
  41 import TyVar            ( GenTyVar{-instances-} )
  42 import Unique           ( Unique{-instances-} )
  43 import Usage            ( GenUsage{-instances-} )
  44 import Util             ( panic{-ToDo:rm-} )
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsection{Public interfaces for Core printing (excluding instances)}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  54 function for ``major'' val_bdrs (those next to equal signs :-),
  55 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  56 usually be called through some intermediary.
  57
  58 The binder/occ printers take the default ``homogenized'' (see
  59 @PprEnv@...) @Pretty@ and the binder/occ.  They can either use the
  60 homogenized one, or they can ignore it completely.  In other words,
  61 the things passed in act as ``hooks'', getting the last word on how to
  62 print something.
  63
  64 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  65
  66 \begin{code}
  67 pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
  68
  69 pprGenCoreBinding
  70         :: (Eq tyvar, Outputable tyvar,
  71             Eq uvar,  Outputable uvar,
  72             Outputable bndr,
  73             Outputable occ)
  74         => PprStyle
  75         -> (bndr -> Pretty)     -- to print "major" val_bdrs
  76         -> (bndr -> Pretty)     -- to print "minor" val_bdrs
  77         -> (occ  -> Pretty)     -- to print bindees
  78         -> GenCoreBinding bndr occ tyvar uvar
  79         -> Pretty
  80
  81 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
  82   = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
  83
  84 init_ppr_env sty pbdr1 pbdr2 pocc
  85   = initPprEnv sty
  86         (Just (ppr sty)) -- literals
  87         (Just (ppr sty)) -- data cons
  88         (Just (ppr sty)) -- primops
  89         (Just (\ cc -> ppStr (showCostCentre sty True cc)))
  90         (Just (ppr sty)) -- tyvars
  91         (Just (ppr sty)) -- usage vars
  92         (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
  93         (Just (ppr sty)) -- types
  94         (Just (ppr sty)) -- usages
  95
  96 --------------
  97 pprCoreBinding sty (NonRec binder expr)
  98   = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
  99          4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 100
 101 pprCoreBinding sty (Rec binds)
 102   = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
 103               ppAboves (map ppr_bind binds),
 104               ifPprDebug sty (ppStr "{- end plain Rec -}")]
 105   where
 106     ppr_bind (binder, expr)
 107       = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
 108              4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 109 \end{code}
 110
 111 \begin{code}
 112 pprCoreExpr
 113         :: PprStyle
 114         -> (Id -> Pretty) -- to print "major" val_bdrs
 115         -> (Id -> Pretty) -- to print "minor" val_bdrs
 116         -> (Id  -> Pretty) -- to print bindees
 117         -> CoreExpr
 118         -> Pretty
 119 pprCoreExpr = pprGenCoreExpr
 120
 121 pprGenCoreExpr, pprParendCoreExpr
 122         :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
 123             Outputable bndr,
 124             Outputable occ)
 125         => PprStyle
 126         -> (bndr -> Pretty) -- to print "major" val_bdrs
 127         -> (bndr -> Pretty) -- to print "minor" val_bdrs
 128         -> (occ  -> Pretty) -- to print bindees
 129         -> GenCoreExpr bndr occ tyvar uvar
 130         -> Pretty
 131
 132 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
 133   = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
 134
 135 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
 136   = let
 137         parenify
 138           = case expr of
 139               Var _ -> id       -- leave unchanged
 140               Lit _ -> id
 141               _     -> ppParens -- wraps in parens
 142     in
 143     parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
 144
 145 ppr_core_arg sty pocc arg
 146   = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
 147
 148 ppr_core_alts sty pbdr1 pbdr2 pocc alts
 149   = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
 150
 151 ppr_core_default sty pbdr1 pbdr2 pocc deflt
 152   = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
 153 \end{code}
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsection{Instance declarations for Core printing}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 instance
 163   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 164    Eq uvar, Outputable uvar)
 165  =>
 166   Outputable (GenCoreBinding bndr occ tyvar uvar) where
 167     ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
 168
 169 instance
 170   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 171    Eq uvar, Outputable uvar)
 172  =>
 173   Outputable (GenCoreExpr bndr occ tyvar uvar) where
 174     ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
 175
 176 instance
 177   (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 178  =>
 179   Outputable (GenCoreArg occ tyvar uvar) where
 180     ppr sty arg = ppr_core_arg sty (ppr sty) arg
 181
 182 instance
 183   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 184    Eq uvar, Outputable uvar)
 185  =>
 186   Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
 187     ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
 188
 189 instance
 190   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 191    Eq uvar, Outputable uvar)
 192  =>
 193   Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
 194     ppr sty deflt  = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
 195 \end{code}
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsection{Workhorse routines (...????...)}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 \begin{code}
 204 ppr_bind pe (NonRec val_bdr expr)
 205   = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 206          4 (ppr_expr pe expr)
 207
 208 ppr_bind pe (Rec binds)
 209   = ppAboves [ ppStr "{- Rec -}",
 210                ppAboves (map ppr_pair binds),
 211                ppStr "{- end Rec -}" ]
 212   where
 213     ppr_pair (val_bdr, expr)
 214       = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 215              4 (ppr_expr pe expr)
 216 \end{code}
 217
 218 \begin{code}
 219 ppr_parend_expr pe expr
 220   = let
 221         parenify
 222           = case expr of
 223               Var _ -> id       -- leave unchanged
 224               Lit _ -> id
 225               _     -> ppParens -- wraps in parens
 226     in
 227     parenify (ppr_expr pe expr)
 228 \end{code}
 229
 230 \begin{code}
 231 ppr_expr pe (Var name)   = pOcc pe name
 232 ppr_expr pe (Lit lit)    = pLit pe lit
 233 ppr_expr pe (Con con []) = pCon pe con
 234
 235 ppr_expr pe (Con con args)
 236   = ppHang (ppBesides [pCon pe con, ppChar '!'])
 237          4 (ppSep (map (ppr_arg pe) args))
 238
 239 ppr_expr pe (Prim prim args)
 240   = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
 241          4 (ppSep (map (ppr_arg pe) args))
 242
 243 ppr_expr pe expr@(Lam _ _)
 244   = let
 245         (uvars, tyvars, vars, body) = collectBinders expr
 246     in
 247     ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar    pe) uvars,
 248                    pp_vars SLIT("_/\\_")  (pTyVar   pe) tyvars,
 249                    pp_vars SLIT("\\")     (pMinBndr pe) vars])
 250          4 (ppr_expr pe body)
 251   where
 252     pp_vars lam pp [] = ppNil
 253     pp_vars lam pp vs
 254       = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
 255
 256 ppr_expr pe expr@(App _ _)
 257   = let
 258         (fun, uargs, targs, vargs) = collectArgs expr
 259     in
 260     ppHang (ppr_parend_expr pe fun)
 261          4 (ppSep [ ppInterleave ppNil (map (pUse    pe) uargs)
 262                   , ppInterleave ppNil (map (pTy     pe) targs)
 263                   , ppInterleave ppNil (map (ppr_arg pe) vargs)
 264                   ])
 265
 266 ppr_expr pe (Case expr alts)
 267   = ppSep
 268     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
 269      ppNest 2 (ppr_alts pe alts),
 270      ppStr "}"]
 271
 272 -- special cases: let ... in let ...
 273 -- ("disgusting" SLPJ)
 274
 275 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 276   = ppAboves [
 277       ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
 278       ppNest 2 (ppr_expr pe rhs),
 279       ppStr "} in",
 280       ppr_expr pe body ]
 281
 282 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 283   = ppAbove
 284       (ppHang (ppStr "let {")
 285             2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 286                            4 (ppr_expr pe rhs),
 287        ppStr "} in"]))
 288       (ppr_expr pe expr)
 289
 290 -- general case (recursive case, too)
 291 ppr_expr pe (Let bind expr)
 292   = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
 293            ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
 294
 295 ppr_expr pe (SCC cc expr)
 296   = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
 297            ppr_parend_expr pe expr ]
 298 \end{code}
 299
 300 \begin{code}
 301 ppr_alts pe (AlgAlts alts deflt)
 302   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 303   where
 304     ppr_alt (con, params, expr)
 305       = ppHang (ppCat [ppr_con con (pCon pe con),
 306                        ppInterleave ppSP (map (pMinBndr pe) params),
 307                        ppStr "->"])
 308              4 (ppr_expr pe expr)
 309       where
 310         ppr_con con pp_con
 311           = if isOpLexeme con then ppParens pp_con else pp_con
 312
 313 ppr_alts pe (PrimAlts alts deflt)
 314   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 315   where
 316     ppr_alt (lit, expr)
 317       = ppHang (ppCat [pLit pe lit, ppStr "->"])
 318              4 (ppr_expr pe expr)
 319 \end{code}
 320
 321 \begin{code}
 322 ppr_default pe NoDefault = ppNil
 323
 324 ppr_default pe (BindDefault val_bdr expr)
 325   = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
 326          4 (ppr_expr pe expr)
 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)  = pTy  pe ty
 333 ppr_arg pe (UsageArg use) = pUse pe use
 334 \end{code}
 335
 336 Other printing bits-and-bobs used with the general @pprCoreBinding@
 337 and @pprCoreExpr@ functions.
 338
 339 \begin{code}
 340 pprBigCoreBinder sty binder
 341   = ppAboves [sig, pragmas, ppr sty binder]
 342   where
 343     sig = ifnotPprShowAll sty (
 344             ppHang (ppCat [ppr sty binder, ppStr "::"])
 345                  4 (ppr sty (idType binder)))
 346
 347     pragmas =
 348         ifnotPprForUser sty
 349          (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
 350           (getIdInfo binder))
 351
 352 pprBabyCoreBinder sty binder
 353   = ppCat [ppr sty binder, pp_strictness]
 354   where
 355     pp_strictness
 356       = case (getIdStrictness binder) of
 357           NoStrictnessInfo    -> ppNil
 358           BottomGuaranteed    -> ppStr "{- _!_ -}"
 359           StrictnessInfo xx _ ->
 360                 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
 361                 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
 362
 363 pprTypedCoreBinder sty binder
 364   = ppBesides [ppLparen, ppCat [ppr sty binder,
 365         ppStr "::", ppr sty (idType binder)],
 366         ppRparen]
 367 \end{code}