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