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