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, SYN_IE(DataCon), GenId{-instances-}
  32                         )
  33 import IdInfo           ( ppIdInfo, StrictnessInfo(..) )
  34 import IdLoop           ( Unfolding )   -- Needed by IdInfo.hi?
  35 import Literal          ( Literal{-instances-} )
  36 import Name             ( isSymLexeme )
  37 import Outputable       -- quite a few things
  38 import PprEnv
  39 import PprType          ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
  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 @PprEnv@...) @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 pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
  70
  71 pprGenCoreBinding
  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 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
  84   = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
  85
  86 init_ppr_env sty pbdr1 pbdr2 pocc
  87   = initPprEnv sty
  88         (Just (ppr sty)) -- literals
  89         (Just (ppr sty)) -- data cons
  90         (Just (ppr sty)) -- primops
  91         (Just (\ cc -> ppStr (showCostCentre sty True cc)))
  92         (Just (ppr sty)) -- tyvars
  93         (Just (ppr sty)) -- usage vars
  94         (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
  95         (Just (pprParendGenType sty)) -- types
  96         (Just (ppr sty)) -- usages
  97
  98 --------------
  99 pprCoreBinding sty (NonRec binder expr)
 100   = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
 101          4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 102
 103 pprCoreBinding sty (Rec binds)
 104   = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
 105               ppAboves (map ppr_bind binds),
 106               ifPprDebug sty (ppStr "{- end plain Rec -}")]
 107   where
 108     ppr_bind (binder, expr)
 109       = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
 110              4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 111 \end{code}
 112
 113 \begin{code}
 114 pprCoreExpr
 115         :: PprStyle
 116         -> (Id -> Pretty) -- to print "major" val_bdrs
 117         -> (Id -> Pretty) -- to print "minor" val_bdrs
 118         -> (Id  -> Pretty) -- to print bindees
 119         -> CoreExpr
 120         -> Pretty
 121 pprCoreExpr = pprGenCoreExpr
 122
 123 pprGenCoreExpr, pprParendCoreExpr
 124         :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
 125             Outputable bndr,
 126             Outputable occ)
 127         => PprStyle
 128         -> (bndr -> Pretty) -- to print "major" val_bdrs
 129         -> (bndr -> Pretty) -- to print "minor" val_bdrs
 130         -> (occ  -> Pretty) -- to print bindees
 131         -> GenCoreExpr bndr occ tyvar uvar
 132         -> Pretty
 133
 134 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
 135   = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
 136
 137 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
 138   = let
 139         parenify
 140           = case expr of
 141               Var _ -> id       -- leave unchanged
 142               Lit _ -> id
 143               _     -> ppParens -- wraps in parens
 144     in
 145     parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
 146
 147 ppr_core_arg sty pocc arg
 148   = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
 149
 150 ppr_core_alts sty pbdr1 pbdr2 pocc alts
 151   = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
 152
 153 ppr_core_default sty pbdr1 pbdr2 pocc deflt
 154   = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
 155 \end{code}
 156
 157 %************************************************************************
 158 %*                                                                      *
 159 \subsection{Instance declarations for Core printing}
 160 %*                                                                      *
 161 %************************************************************************
 162
 163 \begin{code}
 164 instance
 165   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 166    Eq uvar, Outputable uvar)
 167  =>
 168   Outputable (GenCoreBinding bndr occ tyvar uvar) where
 169     ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
 170
 171 instance
 172   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 173    Eq uvar, Outputable uvar)
 174  =>
 175   Outputable (GenCoreExpr bndr occ tyvar uvar) where
 176     ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
 177
 178 instance
 179   (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 180  =>
 181   Outputable (GenCoreArg occ tyvar uvar) where
 182     ppr sty arg = ppr_core_arg sty (ppr sty) arg
 183
 184 instance
 185   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 186    Eq uvar, Outputable uvar)
 187  =>
 188   Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
 189     ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
 190
 191 instance
 192   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 193    Eq uvar, Outputable uvar)
 194  =>
 195   Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
 196     ppr sty deflt  = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
 197 \end{code}
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection{Workhorse routines (...????...)}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 \begin{code}
 206 ppr_bind pe (NonRec val_bdr expr)
 207   = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 208          4 (ppr_expr pe expr)
 209
 210 ppr_bind pe (Rec binds)
 211   = ppAboves [ ppStr "{- Rec -}",
 212                ppAboves (map ppr_pair binds),
 213                ppStr "{- end Rec -}" ]
 214   where
 215     ppr_pair (val_bdr, expr)
 216       = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 217              4 (ppr_expr pe expr)
 218 \end{code}
 219
 220 \begin{code}
 221 ppr_parend_expr pe expr
 222   = let
 223         parenify
 224           = case expr of
 225               Var _ -> id       -- leave unchanged
 226               Lit _ -> id
 227               _     -> ppParens -- wraps in parens
 228     in
 229     parenify (ppr_expr pe expr)
 230 \end{code}
 231
 232 \begin{code}
 233 ppr_expr pe (Var name)   = pOcc pe name
 234 ppr_expr pe (Lit lit)    = pLit pe lit
 235 ppr_expr pe (Con con []) = pCon pe con
 236
 237 ppr_expr pe (Con con args)
 238   = ppHang (ppBesides [pCon pe con, ppChar '!'])
 239          4 (ppSep (map (ppr_arg pe) args))
 240
 241 ppr_expr pe (Prim prim args)
 242   = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
 243          4 (ppSep (map (ppr_arg pe) args))
 244
 245 ppr_expr pe expr@(Lam _ _)
 246   = let
 247         (uvars, tyvars, vars, body) = collectBinders expr
 248     in
 249     ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar    pe) uvars,
 250                    pp_vars SLIT("_/\\_")  (pTyVar   pe) tyvars,
 251                    pp_vars SLIT("\\")     (pMinBndr pe) vars])
 252          4 (ppr_expr pe body)
 253   where
 254     pp_vars lam pp [] = ppNil
 255     pp_vars lam pp vs
 256       = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
 257
 258 ppr_expr pe expr@(App _ _)
 259   = let
 260         (fun, uargs, targs, vargs) = collectArgs expr
 261     in
 262     ppHang (ppr_parend_expr pe fun)
 263          4 (ppSep [ ppInterleave ppNil (map (pUse    pe) uargs)
 264                   , ppInterleave ppNil (map (pTy     pe) targs)
 265                   , ppInterleave ppNil (map (ppr_arg pe) vargs)
 266                   ])
 267
 268 ppr_expr pe (Case expr alts)
 269   | only_one_alt alts
 270     -- johan thinks that single case patterns should be on same line as case,
 271     -- and no indent; all sane persons agree with him.
 272   = let
 273         ppr_alt (AlgAlts  [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
 274         ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
 275         ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l)     (ppStr " ->")
 276         ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
 277           = ppCat [ppr_alt_con con (pCon pe con),
 278                    ppInterleave ppSP (map (pMinBndr pe) params),
 279                    ppStr "->"]
 280
 281         ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
 282         ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
 283         ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
 284         ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
 285     in
 286     ppSep
 287     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
 288          ppBeside (ppr_rhs alts) (ppStr "}")]
 289
 290   | otherwise -- default "case" printing
 291   = ppSep
 292     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
 293      ppNest 2 (ppr_alts pe alts),
 294      ppStr "}"]
 295
 296 -- special cases: let ... in let ...
 297 -- ("disgusting" SLPJ)
 298
 299 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 300   = ppAboves [
 301       ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
 302       ppNest 2 (ppr_expr pe rhs),
 303       ppStr "} in",
 304       ppr_expr pe body ]
 305
 306 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 307   = ppAbove
 308       (ppHang (ppStr "let {")
 309             2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 310                            4 (ppr_expr pe rhs),
 311        ppStr "} in"]))
 312       (ppr_expr pe expr)
 313
 314 -- general case (recursive case, too)
 315 ppr_expr pe (Let bind expr)
 316   = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
 317            ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
 318
 319 ppr_expr pe (SCC cc expr)
 320   = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
 321            ppr_parend_expr pe expr ]
 322
 323 ppr_expr pe (Coerce c ty expr)
 324   = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
 325            pTy pe ty, ppr_parend_expr pe expr ]
 326   where
 327     pp_coerce (CoerceIn  v) = ppBeside (ppStr "{-in-}")  (ppr (pStyle pe) v)
 328     pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
 329
 330 only_one_alt (AlgAlts []     (BindDefault _ _)) = True
 331 only_one_alt (AlgAlts (_:[])  NoDefault)        = True
 332 only_one_alt (PrimAlts []    (BindDefault _ _)) = True
 333 only_one_alt (PrimAlts (_:[]) NoDefault)        = True
 334 only_one_alt _                                  = False
 335
 336 ppr_alt_con con pp_con
 337   = if isSymLexeme con then ppParens pp_con else pp_con
 338 \end{code}
 339
 340 \begin{code}
 341 ppr_alts pe (AlgAlts alts deflt)
 342   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 343   where
 344     ppr_alt (con, params, expr)
 345       = ppHang (if isTupleCon con then
 346                     ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
 347                            ppStr "->"]
 348                 else
 349                     ppCat [ppr_alt_con con (pCon pe con),
 350                            ppInterleave ppSP (map (pMinBndr pe) params),
 351                            ppStr "->"]
 352                )
 353              4 (ppr_expr pe expr)
 354
 355 ppr_alts pe (PrimAlts alts deflt)
 356   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 357   where
 358     ppr_alt (lit, expr)
 359       = ppHang (ppCat [pLit pe lit, ppStr "->"])
 360              4 (ppr_expr pe expr)
 361 \end{code}
 362
 363 \begin{code}
 364 ppr_default pe NoDefault = ppNil
 365
 366 ppr_default pe (BindDefault val_bdr expr)
 367   = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
 368          4 (ppr_expr pe expr)
 369 \end{code}
 370
 371 \begin{code}
 372 ppr_arg pe (LitArg   lit) = pLit pe lit
 373 ppr_arg pe (VarArg   v)   = pOcc pe v
 374 ppr_arg pe (TyArg    ty)  = pTy  pe ty
 375 ppr_arg pe (UsageArg use) = pUse pe use
 376 \end{code}
 377
 378 Other printing bits-and-bobs used with the general @pprCoreBinding@
 379 and @pprCoreExpr@ functions.
 380
 381 \begin{code}
 382 pprBigCoreBinder sty binder
 383   = ppAboves [sig, pragmas, ppr sty binder]
 384   where
 385     sig = ifnotPprShowAll sty (
 386             ppHang (ppCat [ppr sty binder, ppStr "::"])
 387                  4 (ppr sty (idType binder)))
 388
 389     pragmas =
 390         ifnotPprForUser sty
 391          (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
 392           (getIdInfo binder))
 393
 394 pprBabyCoreBinder sty binder
 395   = ppCat [ppr sty binder, pp_strictness]
 396   where
 397     pp_strictness
 398       = case (getIdStrictness binder) of
 399           NoStrictnessInfo    -> ppNil
 400           BottomGuaranteed    -> ppStr "{- _!_ -}"
 401           StrictnessInfo xx _ ->
 402                 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
 403                 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
 404
 405 pprTypedCoreBinder sty binder
 406   = ppBesides [ppLparen, ppCat [ppr sty binder,
 407         ppStr "::", ppr sty (idType binder)],
 408         ppRparen]
 409 \end{code}