ghc/compiler/coreSyn/PprCore.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[PprCore]{Printing of Core syntax, including for interfaces}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 \begin{code}
  11 module PprCore (
  12         pprCoreExpr, pprIfaceUnfolding,
  13         pprCoreBinding, pprCoreBindings, pprIdBndr
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import CoreSyn
  19 import CostCentre       ( pprCostCentreCore )
  20 import Id               ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
  21 import Var              ( isTyVar )
  22 import IdInfo           ( IdInfo,
  23                           arityInfo, ppArityInfo,
  24                           demandInfo, updateInfo, ppUpdateInfo, specInfo,
  25                           strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
  26                           cprInfo, ppCprInfo
  27                         )
  28 import Const            ( Con(..), DataCon )
  29 import DataCon          ( isTupleCon, isUnboxedTupleCon )
  30 import PprType          ( pprParendType, pprTyVarBndr )
  31 import SpecEnv          ( specEnvToList )
  32 import PprEnv
  33 import Outputable
  34 \end{code}
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection{Public interfaces for Core printing (excluding instances)}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  43 function for ``major'' val_bdrs (those next to equal signs :-),
  44 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  45 usually be called through some intermediary.
  46
  47 The binder/occ printers take the default ``homogenized'' (see
  48 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  49 homogenized one, or they can ignore it completely.  In other words,
  50 the things passed in act as ``hooks'', getting the last word on how to
  51 print something.
  52
  53 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  54
  55 Un-annotated core dumps
  56 ~~~~~~~~~~~~~~~~~~~~~~~
  57 \begin{code}
  58 pprCoreBindings :: [CoreBind] -> SDoc
  59 pprCoreBinding  :: CoreBind   -> SDoc
  60 pprCoreExpr     :: CoreExpr   -> SDoc
  61
  62 pprCoreBindings = pprTopBinds pprCoreEnv
  63 pprCoreBinding  = pprTopBind pprCoreEnv
  64 pprCoreExpr     = ppr_expr pprCoreEnv
  65
  66 pprCoreEnv = initCoreEnv pprCoreBinder
  67 \end{code}
  68
  69 Printer for unfoldings in interfaces
  70 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  71 \begin{code}
  72 pprIfaceUnfolding :: CoreExpr -> SDoc
  73 pprIfaceUnfolding = ppr_expr pprIfaceEnv
  74
  75 pprIfaceEnv = initCoreEnv pprIfaceBinder
  76 \end{code}
  77
  78 \begin{code}
  79 instance Outputable b => Outputable (Bind b) where
  80     ppr bind = ppr_bind pprGenericEnv bind
  81
  82 instance Outputable b => Outputable (Expr b) where
  83     ppr expr = ppr_expr pprGenericEnv expr
  84
  85 pprGenericEnv :: Outputable b => PprEnv b
  86 pprGenericEnv = initCoreEnv (\site -> ppr)
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection{Instance declarations for Core printing}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95
  96 \begin{code}
  97 initCoreEnv pbdr
  98   = initPprEnv
  99         (Just ppr)                      -- Constants
 100         (Just pprCostCentreCore)        -- Cost centres
 101
 102         (Just ppr)              -- tyvar occs
 103         (Just pprParendType)    -- types
 104
 105         (Just pbdr) (Just ppr) -- value vars
 106         -- Use pprIdBndr for this last one as a debugging device.
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{The guts}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \begin{code}
 116 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
 117
 118 pprTopBind pe (NonRec binder expr)
 119  = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
 120
 121 pprTopBind pe (Rec binds)
 122   = vcat [ptext SLIT("Rec {"),
 123           vcat (map (ppr_binding_pe pe) binds),
 124           ptext SLIT("end Rec }"),
 125           text ""]
 126 \end{code}
 127
 128 \begin{code}
 129 ppr_bind :: PprEnv b -> Bind b -> SDoc
 130
 131 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 132 ppr_bind pe (Rec binds)           = vcat (map pp binds)
 133                                   where
 134                                     pp bind = ppr_binding_pe pe bind <> semi
 135
 136 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 137 ppr_binding_pe pe (val_bdr, expr)
 138   = sep [pBndr pe LetBind val_bdr,
 139          nest 2 (equals <+> ppr_expr pe expr)]
 140 \end{code}
 141
 142 \begin{code}
 143 ppr_parend_expr pe expr
 144   | no_parens = ppr_expr pe expr
 145   | otherwise = parens (ppr_expr pe expr)
 146   where
 147     no_parens = case expr of
 148                   Var _              -> True
 149                   Con con []         -> True
 150                   Con (DataCon dc) _ -> isTupleCon dc
 151                   _                  -> False
 152 \end{code}
 153
 154 \begin{code}
 155 ppr_expr :: PprEnv b -> Expr b -> SDoc
 156
 157 ppr_expr pe (Type ty)  = ptext SLIT("TYPE") <+> ppr ty  -- Wierd
 158
 159 ppr_expr pe (Var name) = pOcc pe name
 160
 161 ppr_expr pe (Con con [])
 162   = ppr con     -- Nullary constructors too
 163
 164 ppr_expr pe (Con (DataCon dc) args)
 165         -- Drop the type arguments and print in (a,b,c) notation
 166   | isTupleCon dc
 167   = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
 168   | isUnboxedTupleCon dc
 169   = text "(# " <>
 170     hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
 171     text " #)"
 172
 173 ppr_expr pe (Con con args)
 174   = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
 175
 176 ppr_expr pe expr@(Lam _ _)
 177   = let
 178         (bndrs, body) = collectBinders expr
 179     in
 180     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 181          4 (ppr_expr pe body)
 182
 183 ppr_expr pe expr@(App fun arg)
 184   = let
 185         (final_fun, final_args)      = go fun [arg]
 186         go (App fun arg) args_so_far = go fun (arg:args_so_far)
 187         go fun           args_so_far = (fun, args_so_far)
 188     in
 189     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 190
 191 ppr_expr pe (Case expr var [(con,args,rhs)])
 192   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 193               hsep [ptext SLIT("of"),
 194                     ppr_bndr var,
 195                     char '{',
 196                     ppr_case_pat pe con args
 197           ]],
 198          ppr_expr pe rhs,
 199          char '}'
 200     ]
 201   where
 202     ppr_bndr = pBndr pe CaseBind
 203
 204 ppr_expr pe (Case expr var alts)
 205   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 206               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 207          nest 4 (sep (punctuate semi (map ppr_alt alts))),
 208          char '}'
 209     ]
 210   where
 211     ppr_bndr = pBndr pe CaseBind
 212
 213     ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
 214                                     4 (ppr_expr pe rhs)
 215
 216 -- special cases: let ... in let ...
 217 -- ("disgusting" SLPJ)
 218
 219 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 220   = vcat [
 221       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 222       nest 2 (ppr_expr pe rhs),
 223       ptext SLIT("} in"),
 224       ppr_expr pe body ]
 225
 226 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 227   = hang (ptext SLIT("let {"))
 228           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 229                            4 (ppr_expr pe rhs),
 230        ptext SLIT("} in")])
 231     $$
 232     ppr_expr pe expr
 233
 234 -- general case (recursive case, too)
 235 ppr_expr pe (Let bind expr)
 236   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 237          hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
 238   where
 239     keyword = case bind of
 240                 Rec _      -> SLIT("__letrec {")
 241                 NonRec _ _ -> SLIT("let {")
 242
 243 ppr_expr pe (Note (SCC cc) expr)
 244   = sep [pSCC pe cc, ppr_expr pe expr]
 245
 246 #ifdef DEBUG
 247 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 248  = \ sty ->
 249    if debugStyle sty && not (ifaceStyle sty) then
 250       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
 251                   ppr_parend_expr pe expr] sty
 252    else
 253       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 254                   ppr_parend_expr pe expr] sty
 255 #else
 256 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 257   = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 258          ppr_parend_expr pe expr]
 259 #endif
 260
 261 ppr_expr pe (Note InlineCall expr)
 262   = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
 263
 264 ppr_expr pe (Note (TermUsg u) expr)
 265   = \ sty ->
 266     if ifaceStyle sty then
 267       ppr_expr pe expr sty
 268     else
 269       (ppr u <+> ppr_expr pe expr) sty
 270
 271 ppr_case_pat pe con@(DataCon dc) args
 272   | isTupleCon dc
 273   = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 274   | isUnboxedTupleCon dc
 275   = hsep [text "(# " <>
 276           hsep (punctuate comma (map ppr_bndr args)) <>
 277           text " #)",
 278           arrow]
 279   where
 280     ppr_bndr = pBndr pe CaseBind
 281
 282 ppr_case_pat pe con args
 283   = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
 284   where
 285     ppr_bndr = pBndr pe CaseBind
 286
 287 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
 288 ppr_arg pe expr      = ppr_parend_expr pe expr
 289
 290 arrow = ptext SLIT("->")
 291 \end{code}
 292
 293 Other printing bits-and-bobs used with the general @pprCoreBinding@
 294 and @pprCoreExpr@ functions.
 295
 296 \begin{code}
 297 -- Used for printing dump info
 298 pprCoreBinder LetBind binder
 299   = vcat [sig, pragmas, ppr binder]
 300   where
 301     sig     = pprTypedBinder binder
 302     pragmas = ppIdInfo (idInfo binder)
 303
 304 -- Lambda bound type variables are preceded by "@"
 305 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 306
 307 -- Case bound things don't get a signature or a herald
 308 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
 309
 310 -- Used for printing interface-file unfoldings
 311 pprIfaceBinder CaseBind binder = pprUntypedBinder binder
 312 pprIfaceBinder other    binder = pprTypedBinder binder
 313
 314 pprUntypedBinder binder
 315   | isTyVar binder = pprTyVarBndr binder
 316   | otherwise      = pprIdBndr binder
 317
 318 pprTypedBinder binder
 319   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
 320   | otherwise       = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
 321         -- The space before the :: is important; it helps the lexer
 322         -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
 323         --
 324         -- It's important that the type is parenthesised too, at least when
 325         -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 326
 327 -- When printing any Id binder in debug mode, we print its inline pragma
 328 pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))
 329 \end{code}
 330
 331
 332 \begin{code}
 333 ppIdInfo :: IdInfo -> SDoc
 334 ppIdInfo info
 335   = hsep [
 336             ppArityInfo a,
 337             ppUpdateInfo u,
 338             ppStrictnessInfo s,
 339             ppr d,
 340             ppCafInfo c,
 341             ppCprInfo m,
 342             ppSpecInfo p
 343         -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
 344         ]
 345   where
 346     a = arityInfo info
 347     d = demandInfo info
 348     s = strictnessInfo info
 349     u = updateInfo info
 350     c = cafInfo info
 351     m = cprInfo info
 352     p = specInfo info
 353 \end{code}
 354
 355 \begin{code}
 356 ppSpecInfo spec_env
 357   = vcat (map pp_item (specEnvToList spec_env))
 358   where
 359     pp_item (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
 360                                        hsep (map pprParendType tys),
 361                                        ptext SLIT("->"),
 362                                        ppr head]
 363         where
 364            (_, body) = collectBinders rhs
 365            (head, _) = collectArgs body
 366 \end{code}
 367