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         pprPlainCoreBinding
  19
  20         -- these are here to make the instances go in 0.26:
  21 #if __GLASGOW_HASKELL__ <= 26
  22         , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
  23         , GenCoreCaseDefault, GenCoreArg
  24 #endif
  25     ) where
  26
  27 import Ubiq{-uitous-}
  28
  29 import CoreSyn
  30 import CostCentre       ( showCostCentre )
  31 import Id               ( idType, getIdInfo, getIdStrictness,
  32                           nullIdEnv, DataCon(..), GenId{-instances-}
  33                         )
  34 import IdInfo           ( ppIdInfo, StrictnessInfo(..) )
  35 import Literal          ( Literal{-instances-} )
  36 import Outputable       -- quite a few things
  37 import PprType          ( pprType_Internal,
  38                           GenType{-instances-}, GenTyVar{-instance-}
  39                         )
  40 import PprStyle         ( PprStyle(..) )
  41 import Pretty
  42 import PrimOp           ( PrimOp{-instances-} )
  43 import TyVar            ( GenTyVar{-instances-} )
  44 import Unique           ( Unique{-instances-} )
  45 import Usage            ( GenUsage{-instances-} )
  46 import Util             ( panic{-ToDo:rm-} )
  47 \end{code}
  48
  49 %************************************************************************
  50 %*                                                                      *
  51 \subsection{Public interfaces for Core printing (excluding instances)}
  52 %*                                                                      *
  53 %************************************************************************
  54
  55 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  56 function for ``major'' val_bdrs (those next to equal signs :-),
  57 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  58 usually be called through some intermediary.
  59
  60 The binder/occ printers take the default ``homogenized'' (see
  61 @PrintEnv@...) @Pretty@ and the binder/occ.  They can either use the
  62 homogenized one, or they can ignore it completely.  In other words,
  63 the things passed in act as ``hooks'', getting the last word on how to
  64 print something.
  65
  66 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  67
  68 \begin{code}
  69 pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
  70
  71 pprCoreBinding
  72         :: (Eq tyvar, Outputable tyvar,
  73             Eq uvar,  Outputable uvar,
  74             Outputable bndr,
  75             Outputable occ)
  76         => PprStyle
  77         -> (bndr -> Pretty)     -- to print "major" val_bdrs
  78         -> (bndr -> Pretty)     -- to print "minor" val_bdrs
  79         -> (occ  -> Pretty)     -- to print bindees
  80         -> GenCoreBinding bndr occ tyvar uvar
  81         -> Pretty
  82
  83 pprCoreBinding sty pbdr1 pbdr2 pocc bind
  84   = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
  85
  86 pprPlainCoreBinding sty (NonRec binder expr)
  87   = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
  88          4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
  89
  90 pprPlainCoreBinding sty (Rec binds)
  91   = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
  92               ppAboves (map ppr_bind binds),
  93               ifPprDebug sty (ppStr "{- end plain Rec -}")]
  94   where
  95     ppr_bind (binder, expr)
  96       = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
  97              4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
  98 \end{code}
  99
 100 \begin{code}
 101 pprCoreExpr, pprParendCoreExpr
 102         :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
 103             Outputable bndr,
 104             Outputable occ)
 105         => PprStyle
 106         -> (bndr -> Pretty) -- to print "major" val_bdrs
 107         -> (bndr -> Pretty) -- to print "minor" val_bdrs
 108         -> (occ  -> Pretty) -- to print bindees
 109         -> GenCoreExpr bndr occ tyvar uvar
 110         -> Pretty
 111
 112 pprCoreExpr sty pbdr1 pbdr2 pocc expr
 113   = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
 114
 115 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
 116   = let
 117         parenify
 118           = case expr of
 119               Var _ -> id       -- leave unchanged
 120               Lit _ -> id
 121               _     -> ppParens -- wraps in parens
 122     in
 123     parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
 124
 125 ppr_core_arg sty pocc arg
 126   = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
 127
 128 ppr_core_alts sty pbdr1 pbdr2 pocc alts
 129   = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
 130
 131 ppr_core_default sty pbdr1 pbdr2 pocc deflt
 132   = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
 133 \end{code}
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{Instance declarations for Core printing}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 instance
 143   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 144    Eq uvar, Outputable uvar)
 145  =>
 146   Outputable (GenCoreBinding bndr occ tyvar uvar) where
 147     ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
 148
 149 instance
 150   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 151    Eq uvar, Outputable uvar)
 152  =>
 153   Outputable (GenCoreExpr bndr occ tyvar uvar) where
 154     ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
 155
 156 instance
 157   (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 158  =>
 159   Outputable (GenCoreArg occ tyvar uvar) where
 160     ppr sty arg = ppr_core_arg sty (ppr sty) arg
 161
 162 instance
 163   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 164    Eq uvar, Outputable uvar)
 165  =>
 166   Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
 167     ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
 168
 169 instance
 170   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 171    Eq uvar, Outputable uvar)
 172  =>
 173   Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
 174     ppr sty deflt  = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
 175 \end{code}
 176
 177 %************************************************************************
 178 %*                                                                      *
 179 \subsection{Core printing environment (purely local)}
 180 %*                                                                      *
 181 %************************************************************************
 182
 183 Similar to @VE@ in @PprType@.  The ``values'' we print here
 184 are locally-defined nested-scope names; callers to @pprCoreBinding@,
 185 etc., can override these.
 186
 187 For tyvars and uvars, we {\em do} normally use these homogenized
 188 names; for values, we {\em don't}.  In printing interfaces, though,
 189 we use homogenized value names, so that interfaces don't wobble
 190 uncontrollably from changing Unique-based names.
 191
 192 \begin{code}
 193 data PrintEnv tyvar uvar bndr occ
 194   = PE  (Literal -> Pretty)     -- Doing these this way saves
 195         (DataCon -> Pretty)     -- carrying around a PprStyle
 196         (PrimOp  -> Pretty)
 197         (CostCentre -> Pretty)
 198
 199         [Pretty]                -- Tyvar pretty names
 200         (tyvar -> Pretty)       -- Tyvar lookup function
 201         [Pretty]                -- Uvar  pretty names
 202         (uvar -> Pretty)        -- Uvar  lookup function
 203
 204         (GenType tyvar uvar -> Pretty)
 205         (GenUsage uvar -> Pretty)
 206
 207         (ValPrinters bndr occ)
 208
 209 data ValPrinters bndr occ
 210   = BOPE -- print binders/occs differently
 211          (bndr -> Pretty)       -- to print "major" val_bdrs
 212          (bndr -> Pretty)       -- to print "minor" val_bdrs
 213          (occ  -> Pretty)       -- to print bindees
 214
 215   | VPE  -- print all values the same way
 216          [Pretty]               -- Value pretty names
 217          (bndr -> Pretty)       -- Binder lookup function
 218          (occ  -> Pretty)       -- Occurrence lookup function
 219 \end{code}
 220
 221 \begin{code}
 222 initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
 223                Outputable bndr, Outputable occ)
 224            => PprStyle
 225            -> Either
 226                 (bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
 227                 ()
 228            -> PrintEnv tyvar uvar bndr occ
 229
 230 initial_pe sty val_printing
 231   = PE  (ppr sty)   -- for a Literal
 232         (ppr sty)   -- for a DataCon
 233         (ppr sty)   -- for a PrimOp
 234         (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
 235
 236         tv_pretties ppr_tv -- for a TyVar
 237         uv_pretties ppr_uv -- for a UsageVar
 238
 239         (\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
 240         (ppr sty) -- for a Usage
 241
 242         val_printing_stuff
 243   where
 244     ppr_tv = ppr sty -- to print a tyvar
 245     ppr_uv = ppr sty -- to print a uvar
 246
 247     tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
 248                   ++
 249                   map (\ n -> ppBeside (ppChar 'a') (ppInt n))
 250                       ([0 .. ] :: [Int])        -- a0 ... aN
 251
 252     uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
 253                   ++
 254                   map (\ n -> ppBeside (ppChar 'u') (ppInt n))
 255                       ([0 .. ] :: [Int])        -- u0 ... uN
 256
 257     val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
 258                 ++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
 259                        ([0 .. ] :: [Int])       -- v0 ... vN
 260
 261     ------------------------
 262     val_printing_stuff
 263       = case val_printing of
 264           Left  (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
 265           Right () -> VPE val_pretties (ppr sty) (ppr sty)
 266
 267 \end{code}
 268
 269 \begin{code}
 270 plit     (PE pp  _  _  _ _  _ _  _  _  _ _) = pp
 271 pcon     (PE  _ pp  _  _ _  _ _  _  _  _ _) = pp
 272 pprim    (PE  _  _ pp  _ _  _ _  _  _  _ _) = pp
 273 pscc     (PE  _  _  _ pp _  _ _  _  _  _ _) = pp
 274 ptyvar   (PE  _  _  _  _ _ pp _  _  _  _ _) = pp
 275 puvar    (PE  _  _  _  _ _  _ _ pp  _  _ _) = pp
 276
 277 pty      (PE  _  _  _  _ _  _ _  _ pp  _ _) = pp
 278 puse     (PE  _  _  _  _ _  _ _  _  _ pp _) = pp
 279
 280 pmaj_bdr (PE  _  _  _  _ _  _ _  _  _  _ (BOPE pp _ _)) = pp
 281 pmaj_bdr (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ pp _)) = pp
 282
 283 pmin_bdr (PE  _  _  _  _ _  _ _  _  _  _ (BOPE _ pp _)) = pp
 284 pmin_bdr (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ pp _)) = pp
 285
 286 pocc     (PE  _  _  _  _ _  _ _  _  _  _ (BOPE _ _ pp)) = pp
 287 pocc     (PE  _  _  _  _ _  _ _  _  _  _ (VPE  _ _ pp)) = pp
 288 \end{code}
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Workhorse routines (...????...)}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 ppr_bind pe (NonRec val_bdr expr)
 298   = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
 299          4 (ppr_expr pe expr)
 300
 301 ppr_bind pe (Rec binds)
 302   = ppAboves [ ppStr "{- Rec -}",
 303                ppAboves (map ppr_pair binds),
 304                ppStr "{- end Rec -}" ]
 305   where
 306     ppr_pair (val_bdr, expr)
 307       = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
 308              4 (ppr_expr pe expr)
 309 \end{code}
 310
 311 \begin{code}
 312 ppr_parend_expr pe expr
 313   = let
 314         parenify
 315           = case expr of
 316               Var _ -> id       -- leave unchanged
 317               Lit _ -> id
 318               _     -> ppParens -- wraps in parens
 319     in
 320     parenify (ppr_expr pe expr)
 321 \end{code}
 322
 323 \begin{code}
 324 ppr_expr pe (Var name)   = pocc pe name
 325 ppr_expr pe (Lit lit)    = plit pe lit
 326 ppr_expr pe (Con con []) = pcon pe con
 327
 328 ppr_expr pe (Con con args)
 329   = ppHang (ppBesides [pcon pe con, ppChar '!'])
 330          4 (ppSep (map (ppr_arg pe) args))
 331
 332 ppr_expr pe (Prim prim args)
 333   = ppHang (ppBesides [pprim pe prim, ppChar '!'])
 334          4 (ppSep (map (ppr_arg pe) args))
 335
 336 ppr_expr pe expr@(Lam _ _)
 337   = let
 338         (uvars, tyvars, vars, body) = digForLambdas expr
 339     in
 340     ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar    pe) uvars,
 341                    pp_vars SLIT("_/\\_")  (ptyvar   pe) tyvars,
 342                    pp_vars SLIT("\\")     (pmin_bdr pe) vars])
 343          4 (ppr_expr pe body)
 344   where
 345     pp_vars lam pp [] = ppNil
 346     pp_vars lam pp vs
 347       = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
 348
 349 ppr_expr pe expr@(App _ _)
 350   = let
 351         (fun, args) = collectArgs expr
 352     in
 353     ppHang (ppr_parend_expr pe fun)
 354          4 (ppSep (map (ppr_arg pe) args))
 355
 356 ppr_expr pe (Case expr alts)
 357   = ppSep
 358     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
 359      ppNest 2 (ppr_alts pe alts),
 360      ppStr "}"]
 361
 362 -- special cases: let ... in let ...
 363 -- ("disgusting" SLPJ)
 364
 365 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 366   = ppAboves [
 367       ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
 368       ppNest 2 (ppr_expr pe rhs),
 369       ppStr "} in",
 370       ppr_expr pe body ]
 371
 372 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 373   = ppAbove
 374       (ppHang (ppStr "let {")
 375             2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
 376                            4 (ppr_expr pe rhs),
 377        ppStr "} in"]))
 378       (ppr_expr pe expr)
 379
 380 -- general case (recursive case, too)
 381 ppr_expr pe (Let bind expr)
 382   = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
 383            ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
 384
 385 ppr_expr pe (SCC cc expr)
 386   = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
 387            ppr_parend_expr pe expr ]
 388 \end{code}
 389
 390 \begin{code}
 391 ppr_alts pe (AlgAlts alts deflt)
 392   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 393   where
 394     ppr_alt (con, params, expr)
 395       = ppHang (ppCat [ppr_con con (pcon pe con),
 396                        ppInterleave ppSP (map (pmin_bdr pe) params),
 397                        ppStr "->"])
 398              4 (ppr_expr pe expr)
 399       where
 400         ppr_con con pp_con
 401           = if isOpLexeme con then ppParens pp_con else pp_con
 402
 403 ppr_alts pe (PrimAlts alts deflt)
 404   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 405   where
 406     ppr_alt (lit, expr)
 407       = ppHang (ppCat [plit pe lit, ppStr "->"])
 408              4 (ppr_expr pe expr)
 409 \end{code}
 410
 411 \begin{code}
 412 ppr_default pe NoDefault = ppNil
 413
 414 ppr_default pe (BindDefault val_bdr expr)
 415   = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
 416          4 (ppr_expr pe expr)
 417 \end{code}
 418
 419 \begin{code}
 420 ppr_arg pe (LitArg   lit) = plit pe lit
 421 ppr_arg pe (VarArg   v)   = pocc pe v
 422 ppr_arg pe (TyArg    ty)  = pty  pe ty
 423 ppr_arg pe (UsageArg use) = puse pe use
 424 \end{code}
 425
 426 Other printing bits-and-bobs used with the general @pprCoreBinding@
 427 and @pprCoreExpr@ functions.
 428
 429 \begin{code}
 430 pprBigCoreBinder sty binder
 431   = ppAboves [sig, pragmas, ppr sty binder]
 432   where
 433     sig = ifnotPprShowAll sty (
 434             ppHang (ppCat [ppr sty binder, ppStr "::"])
 435                  4 (ppr sty (idType binder)))
 436
 437     pragmas =
 438         ifnotPprForUser sty
 439          (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
 440           (getIdInfo binder))
 441
 442 pprBabyCoreBinder sty binder
 443   = ppCat [ppr sty binder, pp_strictness]
 444   where
 445     pp_strictness
 446       = case (getIdStrictness binder) of
 447           NoStrictnessInfo    -> ppNil
 448           BottomGuaranteed    -> ppStr "{- _!_ -}"
 449           StrictnessInfo xx _ ->
 450                 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
 451                 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
 452
 453 pprTypedCoreBinder sty binder
 454   = ppBesides [ppLparen, ppCat [ppr sty binder,
 455         ppStr "::", ppr sty (idType binder)],
 456         ppRparen]
 457 \end{code}