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