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