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