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, pprParendExpr,
  13         pprCoreBinding, pprCoreBindings, pprIdBndr,
  14         pprCoreBinding, pprCoreBindings,
  15         pprCoreRules, pprCoreRule, pprIdCoreRule
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import CoreSyn
  21 import CostCentre       ( pprCostCentreCore )
  22 import Id               ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
  23                           idInfo, idInlinePragma, idDemandInfo, idOccInfo
  24                         )
  25 import Var              ( isTyVar )
  26 import IdInfo           ( IdInfo, megaSeqIdInfo,
  27                           arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
  28                           specInfo, cprInfo, ppCprInfo,
  29                           strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
  30                           workerInfo, ppWorkerInfo
  31                         )
  32 import DataCon          ( dataConTyCon )
  33 import TyCon            ( tupleTyConBoxity, isTupleTyCon )
  34 import PprType          ( pprParendType, pprTyVarBndr )
  35 import BasicTypes       ( tupleParens )
  36 import PprEnv
  37 import Outputable
  38 \end{code}
  39
  40 %************************************************************************
  41 %*                                                                      *
  42 \subsection{Public interfaces for Core printing (excluding instances)}
  43 %*                                                                      *
  44 %************************************************************************
  45
  46 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  47 function for ``major'' val_bdrs (those next to equal signs :-),
  48 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  49 usually be called through some intermediary.
  50
  51 The binder/occ printers take the default ``homogenized'' (see
  52 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  53 homogenized one, or they can ignore it completely.  In other words,
  54 the things passed in act as ``hooks'', getting the last word on how to
  55 print something.
  56
  57 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  58
  59 Un-annotated core dumps
  60 ~~~~~~~~~~~~~~~~~~~~~~~
  61 \begin{code}
  62 pprCoreBindings :: [CoreBind] -> SDoc
  63 pprCoreBinding  :: CoreBind   -> SDoc
  64 pprCoreExpr     :: CoreExpr   -> SDoc
  65 pprParendExpr   :: CoreExpr   -> SDoc
  66
  67 pprCoreBindings = pprTopBinds pprCoreEnv
  68 pprCoreBinding  = pprTopBind pprCoreEnv
  69 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
  70 pprParendExpr   = ppr_parend_expr   pprCoreEnv
  71 pprArg          = ppr_arg pprCoreEnv
  72
  73 pprCoreEnv = initCoreEnv pprCoreBinder
  74 \end{code}
  75
  76 Printer for unfoldings in interfaces
  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_noparend_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 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  = 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_noparend_expr pe expr)]
 139 \end{code}
 140
 141 \begin{code}
 142 ppr_parend_expr   pe expr = ppr_expr parens pe expr
 143 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
 144
 145 noParens :: SDoc -> SDoc
 146 noParens pp = pp
 147 \end{code}
 148
 149 \begin{code}
 150 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
 151         -- The function adds parens in context that need
 152         -- an atomic value (e.g. function args)
 153
 154 ppr_expr add_par pe (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)        -- Wierd
 155
 156 ppr_expr add_par pe (Var name) = pOcc pe name
 157 ppr_expr add_par pe (Lit lit)  = ppr lit
 158
 159 ppr_expr add_par pe expr@(Lam _ _)
 160   = let
 161         (bndrs, body) = collectBinders expr
 162     in
 163     add_par $
 164     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 165          4 (ppr_noparend_expr pe body)
 166
 167 ppr_expr add_par pe expr@(App fun arg)
 168   = case collectArgs expr of { (fun, args) ->
 169     let
 170         pp_args     = sep (map (ppr_arg pe) args)
 171         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 172         pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
 173     in
 174     case fun of
 175         Var f -> case isDataConId_maybe f of
 176                         -- Notice that we print the *worker*
 177                         -- for tuples in paren'd format.
 178                    Just dc | saturated && isTupleTyCon tc
 179                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 180                            where
 181                              tc        = dataConTyCon dc
 182                              saturated = length val_args == idArity f
 183
 184                    other -> add_par (hang (pOcc pe f) 4 pp_args)
 185
 186         other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args)
 187     }
 188
 189 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
 190   = add_par $
 191     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
 192               hsep [ptext SLIT("of"),
 193                     ppr_bndr var,
 194                     char '{',
 195                     ppr_case_pat pe con args
 196           ]],
 197          ppr_noparend_expr pe rhs,
 198          char '}'
 199     ]
 200   where
 201     ppr_bndr = pBndr pe CaseBind
 202
 203 ppr_expr add_par pe (Case expr var alts)
 204   = add_par $
 205     sep [sep [ptext SLIT("case") <+> ppr_noparend_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_noparend_expr pe rhs)
 215
 216 -- special cases: let ... in let ...
 217 -- ("disgusting" SLPJ)
 218
 219 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 220   = add_par $
 221     vcat [
 222       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 223       nest 2 (ppr_noparend_expr pe rhs),
 224       ptext SLIT("} in"),
 225       ppr_noparend_expr pe body ]
 226
 227 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 228   = add_par
 229     (hang (ptext SLIT("let {"))
 230           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 231                            4 (ppr_noparend_expr pe rhs),
 232        ptext SLIT("} in")])
 233      $$
 234      ppr_noparend_expr pe expr)
 235
 236 -- general case (recursive case, too)
 237 ppr_expr add_par pe (Let bind expr)
 238   = add_par $
 239     sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 240          hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
 241   where
 242     keyword = case bind of
 243                 Rec _      -> SLIT("__letrec {")
 244                 NonRec _ _ -> SLIT("let {")
 245
 246 ppr_expr add_par pe (Note (SCC cc) expr)
 247   = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
 248
 249 #ifdef DEBUG
 250 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 251  = add_par $
 252    getPprStyle $ \ sty ->
 253    if debugStyle sty && not (ifaceStyle sty) then
 254       sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
 255            ppr_parend_expr pe expr]
 256    else
 257       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 258                   ppr_parend_expr pe expr]
 259 #else
 260 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 261   = add_par $
 262     sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
 263          ppr_parend_expr pe expr]
 264 #endif
 265
 266 ppr_expr add_par pe (Note InlineCall expr)
 267   = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
 268
 269 ppr_expr add_par pe (Note InlineMe expr)
 270   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 271
 272 ppr_expr add_par pe (Note (TermUsg u) expr)
 273   = getPprStyle $ \ sty ->
 274     if ifaceStyle sty then
 275       ppr_expr add_par pe expr
 276     else
 277       add_par (ppr u <+> ppr_noparend_expr pe expr)
 278
 279 ppr_case_pat pe con@(DataAlt dc) args
 280   | isTupleTyCon tc
 281   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 282   where
 283     ppr_bndr = pBndr pe CaseBind
 284     tc = dataConTyCon dc
 285
 286 ppr_case_pat pe con args
 287   = ppr con <+> hsep (map ppr_bndr args) <+> arrow
 288   where
 289     ppr_bndr = pBndr pe CaseBind
 290
 291 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
 292 ppr_arg pe expr      = ppr_parend_expr pe expr
 293
 294 arrow = ptext SLIT("->")
 295 \end{code}
 296
 297 Other printing bits-and-bobs used with the general @pprCoreBinding@
 298 and @pprCoreExpr@ functions.
 299
 300 \begin{code}
 301 -- Used for printing dump info
 302 pprCoreBinder LetBind binder
 303   = vcat [sig, pragmas, ppr binder]
 304   where
 305     sig     = pprTypedBinder binder
 306     pragmas = ppIdInfo binder (idInfo binder)
 307
 308 -- Lambda bound type variables are preceded by "@"
 309 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 310
 311 -- Case bound things don't get a signature or a herald
 312 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
 313
 314 pprUntypedBinder binder
 315   | isTyVar binder = ptext SLIT("@") <+> 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 and one-shot-ness
 328 pprIdBndr id = ppr id <+>
 329                (megaSeqIdInfo (idInfo id) `seq`
 330                         -- Useful for poking on black holes
 331                 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
 332                             ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
 333 \end{code}
 334
 335
 336 \begin{code}
 337 ppIdInfo :: Id -> IdInfo -> SDoc
 338 ppIdInfo b info
 339   = hsep [
 340             ppFlavourInfo (flavourInfo info),
 341             ppArityInfo a,
 342             ppWorkerInfo (workerInfo info),
 343             ppStrictnessInfo s,
 344             ppCafInfo c,
 345             ppCprInfo m,
 346             pprCoreRules b p
 347         -- Inline pragma, occ, demand, lbvar info
 348         -- printed out with all binders (when debug is on);
 349         -- see PprCore.pprIdBndr
 350         ]
 351   where
 352     a = arityInfo info
 353     s = strictnessInfo info
 354     c = cafInfo info
 355     m = cprInfo info
 356     p = specInfo info
 357 \end{code}
 358
 359
 360 \begin{code}
 361 pprCoreRules :: Id -> CoreRules -> SDoc
 362 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
 363
 364 pprIdCoreRule :: IdCoreRule -> SDoc
 365 pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
 366
 367 pprCoreRule :: SDoc -> CoreRule -> SDoc
 368 pprCoreRule pp_fn (BuiltinRule _)
 369   = ifPprDebug (ptext SLIT("A built in rule"))
 370
 371 pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs)
 372   = doubleQuotes (ptext name) <+>
 373     sep [
 374           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 375           nest 4 (pp_fn <+> sep (map pprArg tpl_args)),
 376           nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs)
 377     ] <+> semi
 378 \end{code}