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           ( ppIdInfo )
  23 import Const            ( Con(..), DataCon )
  24 import DataCon          ( isTupleCon, isUnboxedTupleCon )
  25 import PprType          ( pprParendType, pprTyVarBndr )
  26 import PprEnv
  27 import Outputable
  28 \end{code}
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \subsection{Public interfaces for Core printing (excluding instances)}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  37 function for ``major'' val_bdrs (those next to equal signs :-),
  38 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  39 usually be called through some intermediary.
  40
  41 The binder/occ printers take the default ``homogenized'' (see
  42 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  43 homogenized one, or they can ignore it completely.  In other words,
  44 the things passed in act as ``hooks'', getting the last word on how to
  45 print something.
  46
  47 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  48
  49 Un-annotated core dumps
  50 ~~~~~~~~~~~~~~~~~~~~~~~
  51 \begin{code}
  52 pprCoreBindings :: [CoreBind] -> SDoc
  53 pprCoreBinding  :: CoreBind   -> SDoc
  54 pprCoreExpr     :: CoreExpr   -> SDoc
  55
  56 pprCoreBindings = pprTopBinds pprCoreEnv
  57 pprCoreBinding  = pprTopBind pprCoreEnv
  58 pprCoreExpr     = ppr_expr pprCoreEnv
  59
  60 pprCoreEnv = initCoreEnv pprCoreBinder
  61 \end{code}
  62
  63 Printer for unfoldings in interfaces
  64 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  65 \begin{code}
  66 pprIfaceUnfolding :: CoreExpr -> SDoc
  67 pprIfaceUnfolding = ppr_expr pprIfaceEnv
  68
  69 pprIfaceEnv = initCoreEnv pprIfaceBinder
  70 \end{code}
  71
  72 \begin{code}
  73 instance Outputable b => Outputable (Bind b) where
  74     ppr bind = ppr_bind pprGenericEnv bind
  75
  76 instance Outputable b => Outputable (Expr b) where
  77     ppr expr = ppr_expr pprGenericEnv expr
  78
  79 pprGenericEnv :: Outputable b => PprEnv b
  80 pprGenericEnv = initCoreEnv (\site -> ppr)
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection{Instance declarations for Core printing}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89
  90 \begin{code}
  91 initCoreEnv pbdr
  92   = initPprEnv
  93         (Just ppr)                      -- Constants
  94         (Just pprCostCentreCore)        -- Cost centres
  95
  96         (Just ppr)              -- tyvar occs
  97         (Just pprParendType)    -- types
  98
  99         (Just pbdr) (Just pprIdBndr) -- value vars
 100         -- The pprIdBndr part here is a temporary debugging aid
 101         -- Revert to ppr if it gets tiresome
 102 \end{code}
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{The guts}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
 112
 113 pprTopBind pe (NonRec binder expr)
 114  = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
 115
 116 pprTopBind pe (Rec binds)
 117   = vcat [ptext SLIT("Rec {"),
 118           vcat (map (ppr_binding_pe pe) binds),
 119           ptext SLIT("end Rec }"),
 120           text ""]
 121 \end{code}
 122
 123 \begin{code}
 124 ppr_bind :: PprEnv b -> Bind b -> SDoc
 125
 126 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 127 ppr_bind pe (Rec binds)           = vcat (map pp binds)
 128                                   where
 129                                     pp bind = ppr_binding_pe pe bind <> semi
 130
 131 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 132 ppr_binding_pe pe (val_bdr, expr)
 133   = sep [pBndr pe LetBind val_bdr,
 134          nest 2 (equals <+> ppr_expr pe expr)]
 135 \end{code}
 136
 137 \begin{code}
 138 ppr_parend_expr pe expr
 139   | no_parens = ppr_expr pe expr
 140   | otherwise = parens (ppr_expr pe expr)
 141   where
 142     no_parens = case expr of
 143                   Var _              -> True
 144                   Con con []         -> True
 145                   Con (DataCon dc) _ -> isTupleCon dc
 146                   _                  -> False
 147 \end{code}
 148
 149 \begin{code}
 150 ppr_expr :: PprEnv b -> Expr b -> SDoc
 151
 152 ppr_expr pe (Type ty)  = ptext SLIT("TYPE") <+> ppr ty  -- Wierd
 153
 154 ppr_expr pe (Var name) = pOcc pe name
 155
 156 ppr_expr pe (Con con [])
 157   = ppr con     -- Nullary constructors too
 158
 159 ppr_expr pe (Con (DataCon dc) args)
 160         -- Drop the type arguments and print in (a,b,c) notation
 161   | isTupleCon dc
 162   = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
 163   | isUnboxedTupleCon dc
 164   = text "(# " <>
 165     hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
 166     text " #)"
 167
 168 ppr_expr pe (Con con args)
 169   = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
 170
 171 ppr_expr pe expr@(Lam _ _)
 172   = let
 173         (bndrs, body) = collectBinders expr
 174     in
 175     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 176          4 (ppr_expr pe body)
 177
 178 ppr_expr pe expr@(App fun arg)
 179   = let
 180         (final_fun, final_args)      = go fun [arg]
 181         go (App fun arg) args_so_far = go fun (arg:args_so_far)
 182         go fun           args_so_far = (fun, args_so_far)
 183     in
 184     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 185
 186 ppr_expr pe (Case expr var [(con,args,rhs)])
 187   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 188               hsep [ptext SLIT("of"),
 189                     ppr_bndr var,
 190                     char '{',
 191                     ppr_case_pat pe con args
 192           ]],
 193          ppr_expr pe rhs,
 194          char '}'
 195     ]
 196   where
 197     ppr_bndr = pBndr pe CaseBind
 198
 199 ppr_expr pe (Case expr var alts)
 200   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 201               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 202          nest 4 (sep (punctuate semi (map ppr_alt alts))),
 203          char '}'
 204     ]
 205   where
 206     ppr_bndr = pBndr pe CaseBind
 207
 208     ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
 209                                     4 (ppr_expr pe rhs)
 210
 211 -- special cases: let ... in let ...
 212 -- ("disgusting" SLPJ)
 213
 214 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 215   = vcat [
 216       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 217       nest 2 (ppr_expr pe rhs),
 218       ptext SLIT("} in"),
 219       ppr_expr pe body ]
 220
 221 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 222   = hang (ptext SLIT("let {"))
 223           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 224                            4 (ppr_expr pe rhs),
 225        ptext SLIT("} in")])
 226     $$
 227     ppr_expr pe expr
 228
 229 -- general case (recursive case, too)
 230 ppr_expr pe (Let bind expr)
 231   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 232          hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
 233   where
 234     keyword = case bind of
 235                 Rec _      -> SLIT("__letrec {")
 236                 NonRec _ _ -> SLIT("let {")
 237
 238 ppr_expr pe (Note (SCC cc) expr)
 239   = sep [pSCC pe cc, ppr_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("@") <+> 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 "@"
 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("@") <+> pprTyVarBndr binder
 308   | otherwise       = pprIdBndr binder <+> dcolon <+> 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}