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