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 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   | only_one_alt alts
 269     -- johan thinks that single case patterns should be on same line as case,
 270     -- and no indent; all sane persons agree with him.
 271   = let
 272         ppr_alt (AlgAlts  [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
 273         ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
 274         ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l)     (ppStr " ->")
 275         ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
 276           = ppCat [ppr_alt_con con (pCon pe con),
 277                    ppInterleave ppSP (map (pMinBndr pe) params),
 278                    ppStr "->"]
 279
 280         ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
 281         ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
 282         ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
 283         ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
 284     in
 285     ppSep
 286     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
 287          ppBeside (ppr_rhs alts) (ppStr "}")]
 288
 289   | otherwise -- default "case" printing
 290   = ppSep
 291     [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
 292      ppNest 2 (ppr_alts pe alts),
 293      ppStr "}"]
 294
 295 -- special cases: let ... in let ...
 296 -- ("disgusting" SLPJ)
 297
 298 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 299   = ppAboves [
 300       ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
 301       ppNest 2 (ppr_expr pe rhs),
 302       ppStr "} in",
 303       ppr_expr pe body ]
 304
 305 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 306   = ppAbove
 307       (ppHang (ppStr "let {")
 308             2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
 309                            4 (ppr_expr pe rhs),
 310        ppStr "} in"]))
 311       (ppr_expr pe expr)
 312
 313 -- general case (recursive case, too)
 314 ppr_expr pe (Let bind expr)
 315   = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
 316            ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
 317
 318 ppr_expr pe (SCC cc expr)
 319   = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
 320            ppr_parend_expr pe expr ]
 321
 322 ppr_expr pe (Coerce c ty expr)
 323   = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
 324            pTy pe ty, ppr_parend_expr pe expr ]
 325   where
 326     pp_coerce (CoerceIn  v) = ppBeside (ppStr "{-in-}")  (ppr (pStyle pe) v)
 327     pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
 328
 329 only_one_alt (AlgAlts []     (BindDefault _ _)) = True
 330 only_one_alt (AlgAlts (_:[])  NoDefault)        = True
 331 only_one_alt (PrimAlts []    (BindDefault _ _)) = True
 332 only_one_alt (PrimAlts (_:[]) NoDefault)        = True
 333 only_one_alt _                                  = False
 334
 335 ppr_alt_con con pp_con
 336   = if isSymLexeme con then ppParens pp_con else pp_con
 337 \end{code}
 338
 339 \begin{code}
 340 ppr_alts pe (AlgAlts alts deflt)
 341   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 342   where
 343     ppr_alt (con, params, expr)
 344       = ppHang (if isTupleCon con then
 345                     ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
 346                            ppStr "->"]
 347                 else
 348                     ppCat [ppr_alt_con con (pCon pe con),
 349                            ppInterleave ppSP (map (pMinBndr pe) params),
 350                            ppStr "->"]
 351                )
 352              4 (ppr_expr pe expr)
 353
 354 ppr_alts pe (PrimAlts alts deflt)
 355   = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
 356   where
 357     ppr_alt (lit, expr)
 358       = ppHang (ppCat [pLit pe lit, ppStr "->"])
 359              4 (ppr_expr pe expr)
 360 \end{code}
 361
 362 \begin{code}
 363 ppr_default pe NoDefault = ppNil
 364
 365 ppr_default pe (BindDefault val_bdr expr)
 366   = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
 367          4 (ppr_expr pe expr)
 368 \end{code}
 369
 370 \begin{code}
 371 ppr_arg pe (LitArg   lit) = pLit pe lit
 372 ppr_arg pe (VarArg   v)   = pOcc pe v
 373 ppr_arg pe (TyArg    ty)  = pTy  pe ty
 374 ppr_arg pe (UsageArg use) = pUse pe use
 375 \end{code}
 376
 377 Other printing bits-and-bobs used with the general @pprCoreBinding@
 378 and @pprCoreExpr@ functions.
 379
 380 \begin{code}
 381 pprBigCoreBinder sty binder
 382   = ppAboves [sig, pragmas, ppr sty binder]
 383   where
 384     sig = ifnotPprShowAll sty (
 385             ppHang (ppCat [ppr sty binder, ppStr "::"])
 386                  4 (ppr sty (idType binder)))
 387
 388     pragmas =
 389         ifnotPprForUser sty
 390          (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
 391           (getIdInfo binder))
 392
 393 pprBabyCoreBinder sty binder
 394   = ppCat [ppr sty binder, pp_strictness]
 395   where
 396     pp_strictness
 397       = case (getIdStrictness binder) of
 398           NoStrictnessInfo    -> ppNil
 399           BottomGuaranteed    -> ppStr "{- _!_ -}"
 400           StrictnessInfo xx _ ->
 401                 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
 402                 -- ppStr ("{- " ++ (showList xx "") ++ " -}")
 403
 404 pprTypedCoreBinder sty binder
 405   = ppBesides [ppLparen, ppCat [ppr sty binder,
 406         ppStr "::", ppr sty (idType binder)],
 407         ppRparen]
 408 \end{code}