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