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                           SYN_IE(Id)
  33                         )
  34 import IdInfo           ( ppIdInfo, StrictnessInfo(..) )
  35 import Literal          ( Literal{-instances-} )
  36 import Name             ( OccName, parenInCode )
  37 import Outputable       -- quite a few things
  38 import PprEnv
  39 import PprType          ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
  40 import PprStyle         ( PprStyle(..), ifaceStyle )
  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@...) @Doc@ 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 -> Doc
  70
  71 pprGenCoreBinding
  72         :: (Eq tyvar,  Outputable tyvar,
  73             Eq uvar,  Outputable uvar,
  74             Outputable bndr,
  75             Outputable occ)
  76         => PprStyle
  77         -> (bndr -> Doc)        -- to print "major" val_bdrs
  78         -> (bndr -> Doc)        -- to print "minor" val_bdrs
  79         -> (occ  -> Doc)        -- to print bindees
  80         -> GenCoreBinding bndr occ tyvar uvar
  81         -> Doc
  82
  83 pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
  84   = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
  85
  86 init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
  87   = initPprEnv sty
  88         (Just (ppr sty)) -- literals
  89         (Just ppr_con)          -- data cons
  90         (Just ppr_prim)         -- primops
  91         (Just (\ cc -> text (showCostCentre sty True cc)))
  92         (Just tvbndr)           -- tyvar binders
  93         (Just (ppr sty))        -- tyvar occs
  94         (Just (ppr sty))        -- usage vars
  95         (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
  96         (Just (pprParendGenType sty)) -- types
  97         (Just (ppr sty))        -- usages
  98   where
  99
 100     ppr_con con = ppr sty con
 101
 102 {-      [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
 103         [We can't treat them as ordinary applications because the Con doesn't have
 104          dictionaries in it, whereas the constructor Id does.]
 105
 106         OLD VERSION:
 107         -- ppr_con is used when printing Con expressions; we add a "!"
 108         -- to distinguish them from ordinary applications.  But not when
 109         -- printing for interfaces, where they are treated as ordinary applications
 110     ppr_con con | ifaceStyle sty = ppr sty con
 111                 | otherwise      = ppr sty con <> char '!'
 112 -}
 113
 114         -- We add a "!" to distinguish Primitive applications from ordinary applications.
 115         -- But not when printing for interfaces, where they are treated
 116         -- as ordinary applications
 117     ppr_prim prim | ifaceStyle sty = ppr sty prim
 118                   | otherwise      = ppr sty prim <> char '!'
 119
 120 --------------
 121 pprCoreBinding sty (NonRec binder expr)
 122   = hang (hsep [pprBigCoreBinder sty binder, equals])
 123          4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 124
 125 pprCoreBinding sty (Rec binds)
 126   = vcat [ptext SLIT("Rec {"),
 127               vcat (map ppr_bind binds),
 128               ptext SLIT("end Rec }")]
 129   where
 130     ppr_bind (binder, expr)
 131       = hang (hsep [pprBigCoreBinder sty binder, equals])
 132              4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
 133 \end{code}
 134
 135 \begin{code}
 136 pprCoreExpr
 137         :: PprStyle
 138         -> (Id -> Doc) -- to print "major" val_bdrs
 139         -> (Id -> Doc) -- to print "minor" val_bdrs
 140         -> (Id  -> Doc) -- to print bindees
 141         -> CoreExpr
 142         -> Doc
 143 pprCoreExpr = pprGenCoreExpr
 144
 145 pprGenCoreExpr, pprParendCoreExpr
 146         :: (Eq tyvar, Outputable tyvar,
 147             Eq uvar, Outputable uvar,
 148             Outputable bndr,
 149             Outputable occ)
 150         => PprStyle
 151         -> (bndr -> Doc) -- to print "major" val_bdrs
 152         -> (bndr -> Doc) -- to print "minor" val_bdrs
 153         -> (occ  -> Doc) -- to print bindees
 154         -> GenCoreExpr bndr occ tyvar uvar
 155         -> Doc
 156
 157 pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
 158   = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
 159
 160 pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
 161   = let
 162         parenify
 163           = case expr of
 164               Var _ -> id       -- leave unchanged
 165               Lit _ -> id
 166               _     -> parens   -- wraps in parens
 167     in
 168     parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
 169
 170 -- Printer for unfoldings in interfaces
 171 pprIfaceUnfolding :: CoreExpr -> Doc
 172 pprIfaceUnfolding = ppr_expr env
 173   where
 174     env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
 175                                     (pprTypedCoreBinder PprInterface)
 176                                     (ppr PprInterface)
 177                                     (ppr PprInterface)
 178
 179 ppr_core_arg sty pocc arg
 180   = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
 181
 182 ppr_core_alts sty pbdr1 pbdr2 pocc alts
 183   = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
 184
 185 ppr_core_default sty pbdr1 pbdr2 pocc deflt
 186   = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection{Instance declarations for Core printing}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 \begin{code}
 196 instance
 197   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 198    Eq uvar, Outputable uvar)
 199  =>
 200   Outputable (GenCoreBinding bndr occ tyvar uvar) where
 201     ppr sty bind = pprQuote sty $ \sty ->
 202                    pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
 203
 204 instance
 205   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 206    Eq uvar, Outputable uvar)
 207  =>
 208   Outputable (GenCoreExpr bndr occ tyvar uvar) where
 209     ppr sty expr = pprQuote sty $ \sty ->
 210                    pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
 211
 212 instance
 213   (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
 214  =>
 215   Outputable (GenCoreArg occ tyvar uvar) where
 216     ppr sty arg = pprQuote sty $ \sty ->
 217                   ppr_core_arg sty (ppr sty) arg
 218
 219 instance
 220   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 221    Eq uvar, Outputable uvar)
 222  =>
 223   Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
 224     ppr sty alts = pprQuote sty $ \sty ->
 225                    ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
 226
 227 instance
 228   (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
 229    Eq uvar, Outputable uvar)
 230  =>
 231   Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
 232     ppr sty deflt  = pprQuote sty $ \sty ->
 233                      ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsection{Workhorse routines (...????...)}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 ppr_bind pe (NonRec val_bdr expr)
 244   = hang (hsep [pMajBndr pe val_bdr, equals])
 245          4 (ppr_expr pe expr)
 246
 247 ppr_bind pe (Rec binds)
 248   = vcat (map ppr_pair binds)
 249   where
 250     ppr_pair (val_bdr, expr)
 251       = hang (hsep [pMajBndr pe val_bdr, equals])
 252              4 (ppr_expr pe expr <> semi)
 253 \end{code}
 254
 255 \begin{code}
 256 ppr_parend_expr pe expr
 257   = let
 258         parenify
 259           = case expr of
 260               Var _ -> id       -- leave unchanged
 261               Lit _ -> id
 262               _     -> parens   -- wraps in parens
 263     in
 264     parenify (ppr_expr pe expr)
 265 \end{code}
 266
 267 \begin{code}
 268 ppr_expr pe (Var name)   = pOcc pe name
 269 ppr_expr pe (Lit lit)    = pLit pe lit
 270
 271 ppr_expr pe (Con con args)
 272   = hang (pCon pe con)
 273          4 (braces $ sep (map (ppr_arg pe) args))
 274
 275 ppr_expr pe (Prim prim args)
 276   = hang (pPrim pe prim)
 277          4 (sep (map (ppr_arg pe) args))
 278
 279 ppr_expr pe expr@(Lam _ _)
 280   = let
 281         (uvars, tyvars, vars, body) = collectBinders expr
 282     in
 283     hang (hsep [pp_vars SLIT("/u\\") (pUVar    pe) uvars,
 284                    pp_vars SLIT("_/\\_")  (pTyVarB  pe) tyvars,
 285                    pp_vars SLIT("\\")   (pMajBndr pe) vars])
 286          4 (ppr_expr pe body)
 287   where
 288     pp_vars lam pp [] = empty
 289     pp_vars lam pp vs
 290       = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
 291
 292 ppr_expr pe expr@(App fun arg)
 293   = let
 294         (final_fun, final_args)      = go fun [arg]
 295         go (App fun arg) args_so_far = go fun (arg:args_so_far)
 296         go fun           args_so_far = (fun, args_so_far)
 297     in
 298     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 299
 300 ppr_expr pe (Case expr alts)
 301   | only_one_alt alts
 302     -- johan thinks that single case patterns should be on same line as case,
 303     -- and no indent; all sane persons agree with him.
 304   = let
 305
 306         ppr_alt (AlgAlts  [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
 307         ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
 308         ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l)         ppr_arrow
 309         ppr_alt (AlgAlts  ((con, params, _):[]) NoDefault)
 310           = hsep [pCon pe con,
 311                    hsep (map (pMinBndr pe) params),
 312                    ppr_arrow]
 313
 314         ppr_rhs (AlgAlts [] (BindDefault _ expr))   = ppr_expr pe expr
 315         ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
 316         ppr_rhs (PrimAlts [] (BindDefault _ expr))  = ppr_expr pe expr
 317         ppr_rhs (PrimAlts ((_,expr):[]) NoDefault)  = ppr_expr pe expr
 318
 319
 320         ppr_arrow = ptext SLIT(" ->")
 321     in
 322     sep
 323     [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
 324             (<>) (ppr_rhs alts) (text ";}")]
 325
 326   | otherwise -- default "case" printing
 327   = sep
 328     [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
 329      nest 2 (ppr_alts pe alts),
 330      text "}"]
 331   where
 332     pp_keyword = case alts of
 333                   AlgAlts _ _  -> ptext SLIT("case")
 334                   PrimAlts _ _ -> ptext SLIT("case#")
 335
 336 -- special cases: let ... in let ...
 337 -- ("disgusting" SLPJ)
 338
 339 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 340   = vcat [
 341       hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals],
 342       nest 2 (ppr_expr pe rhs),
 343       ptext SLIT("} in"),
 344       ppr_expr pe body ]
 345
 346 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 347   = ($$)
 348       (hang (ptext SLIT("let {"))
 349             2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals])
 350                            4 (ppr_expr pe rhs),
 351        ptext SLIT("} in")]))
 352       (ppr_expr pe expr)
 353
 354 -- general case (recursive case, too)
 355 ppr_expr pe (Let bind expr)
 356   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 357            hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
 358   where
 359     keyword = case bind of
 360                 Rec _      -> SLIT("_letrec_ {")
 361                 NonRec _ _ -> SLIT("let {")
 362
 363 ppr_expr pe (SCC cc expr)
 364   = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
 365            ppr_parend_expr pe expr ]
 366
 367 ppr_expr pe (Coerce c ty expr)
 368   = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
 369   where
 370     pp_coerce (CoerceIn  v) = (<>) (ptext SLIT("_coerce_in_ "))  (ppr (pStyle pe) v)
 371     pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v)
 372
 373 only_one_alt (AlgAlts []     (BindDefault _ _)) = True
 374 only_one_alt (AlgAlts (_:[])  NoDefault)        = True
 375 only_one_alt (PrimAlts []    (BindDefault _ _)) = True
 376 only_one_alt (PrimAlts (_:[]) NoDefault)        = True
 377 only_one_alt _                                  = False
 378 \end{code}
 379
 380 \begin{code}
 381 ppr_alts pe (AlgAlts alts deflt)
 382   = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
 383   where
 384     ppr_arrow = ptext SLIT("->")
 385
 386     ppr_alt (con, params, expr)
 387       = hang (if isTupleCon con then
 388                     hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))),
 389                           ppr_arrow]
 390                 else
 391                     hsep [pCon pe con,
 392                           hsep (map (pMinBndr pe) params),
 393                            ppr_arrow]
 394                )
 395              4 (ppr_expr pe expr <> semi)
 396
 397 ppr_alts pe (PrimAlts alts deflt)
 398   = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
 399   where
 400     ppr_alt (lit, expr)
 401       = hang (hsep [pLit pe lit, ptext SLIT("->")])
 402              4 (ppr_expr pe expr <> semi)
 403 \end{code}
 404
 405 \begin{code}
 406 ppr_default pe NoDefault = empty
 407
 408 ppr_default pe (BindDefault val_bdr expr)
 409   = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
 410          4 (ppr_expr pe expr <> semi)
 411 \end{code}
 412
 413 \begin{code}
 414 ppr_arg pe (LitArg   lit) = pLit pe lit
 415 ppr_arg pe (VarArg   v)   = pOcc pe v
 416 ppr_arg pe (TyArg    ty)  = ptext SLIT("_@_ ") <> pTy pe ty
 417 ppr_arg pe (UsageArg use) = pUse pe use
 418 \end{code}
 419
 420 Other printing bits-and-bobs used with the general @pprCoreBinding@
 421 and @pprCoreExpr@ functions.
 422
 423 \begin{code}
 424 pprBigCoreBinder sty binder
 425   = vcat [sig, pragmas, ppr sty binder]
 426   where
 427     sig = ifnotPprShowAll sty (
 428             hang (hsep [ppr sty binder, ppDcolon])
 429                  4 (ppr sty (idType binder)))
 430     pragmas =
 431         ifnotPprForUser sty
 432          (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
 433
 434 pprBabyCoreBinder sty binder
 435   = hsep [ppr sty binder, pp_strictness]
 436   where
 437     pp_strictness
 438       = case (getIdStrictness binder) of
 439           NoStrictnessInfo    -> empty
 440           BottomGuaranteed    -> ptext SLIT("{- _!_ -}")
 441           StrictnessInfo xx _ ->
 442                 panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
 443                 -- text ("{- " ++ (showList xx "") ++ " -}")
 444
 445 pprTypedCoreBinder sty binder
 446   = hcat [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
 447
 448 ppDcolon = ptext SLIT(" :: ")
 449                 -- The space before the :: is important; it helps the lexer
 450                 -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
 451 \end{code}