compiler/coreSyn/PprCore.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The AQUA Project, Glasgow University, 1996-1998
   4 %
   5
   6 Printing of Core syntax
   7
   8 \begin{code}
   9 module PprCore (
  10         pprCoreExpr, pprParendExpr,
  11         pprCoreBinding, pprCoreBindings, pprCoreAlt,
  12         pprRules
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn
  18 import CostCentre
  19 import Var
  20 import Id
  21 import IdInfo
  22 import NewDemand
  23 #ifdef OLD_STRICTNESS
  24 import Id
  25 import IdInfo
  26 #endif
  27
  28 import DataCon
  29 import TyCon
  30 import Type
  31 import Coercion
  32 import BasicTypes
  33 import Util
  34 import Outputable
  35 import FastString
  36 import Module
  37 \end{code}
  38
  39 %************************************************************************
  40 %*                                                                      *
  41 \subsection{Public interfaces for Core printing (excluding instances)}
  42 %*                                                                      *
  43 %************************************************************************
  44
  45 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  46
  47 \begin{code}
  48 pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
  49 pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc
  50 pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc
  51 pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc
  52
  53 pprCoreBindings = pprTopBinds
  54 pprCoreBinding  = pprTopBind
  55
  56 instance OutputableBndr b => Outputable (Bind b) where
  57     ppr bind = ppr_bind bind
  58
  59 instance OutputableBndr b => Outputable (Expr b) where
  60     ppr expr = pprCoreExpr expr
  61 \end{code}
  62
  63
  64 %************************************************************************
  65 %*                                                                      *
  66 \subsection{The guts}
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 pprTopBinds binds = vcat (map pprTopBind binds)
  72
  73 pprTopBind (NonRec binder expr)
  74  = ppr_binding (binder,expr) $$ text ""
  75
  76 pprTopBind (Rec binds)
  77   = vcat [ptext SLIT("Rec {"),
  78           vcat (map ppr_binding binds),
  79           ptext SLIT("end Rec }"),
  80           text ""]
  81 \end{code}
  82
  83 \begin{code}
  84 ppr_bind :: OutputableBndr b => Bind b -> SDoc
  85
  86 ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
  87 ppr_bind (Rec binds)           = vcat (map pp binds)
  88                                where
  89                                  pp bind = ppr_binding bind <> semi
  90
  91 ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
  92 ppr_binding (val_bdr, expr)
  93   = pprBndr LetBind val_bdr $$
  94     hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr)
  95 \end{code}
  96
  97 \begin{code}
  98 pprParendExpr   expr = ppr_expr parens expr
  99 pprCoreExpr expr = ppr_expr noParens expr
 100
 101 noParens :: SDoc -> SDoc
 102 noParens pp = pp
 103 \end{code}
 104
 105 \begin{code}
 106 ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
 107         -- The function adds parens in context that need
 108         -- an atomic value (e.g. function args)
 109
 110 ppr_expr add_par (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)   -- Wierd
 111
 112 ppr_expr add_par (Var name) = ppr name
 113 ppr_expr add_par (Lit lit)  = ppr lit
 114
 115 ppr_expr add_par (Cast expr co)
 116   = add_par $
 117     sep [pprParendExpr expr,
 118          ptext SLIT("`cast`") <+> parens (pprCo co)]
 119   where
 120     pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
 121
 122
 123 ppr_expr add_par expr@(Lam _ _)
 124   = let
 125         (bndrs, body) = collectBinders expr
 126     in
 127     add_par $
 128     hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
 129          2 (pprCoreExpr body)
 130
 131 ppr_expr add_par expr@(App fun arg)
 132   = case collectArgs expr of { (fun, args) ->
 133     let
 134         pp_args     = sep (map pprArg args)
 135         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 136         pp_tup_args = sep (punctuate comma (map pprArg val_args))
 137     in
 138     case fun of
 139         Var f -> case isDataConWorkId_maybe f of
 140                         -- Notice that we print the *worker*
 141                         -- for tuples in paren'd format.
 142                    Just dc | saturated && isTupleTyCon tc
 143                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 144                            where
 145                              tc        = dataConTyCon dc
 146                              saturated = val_args `lengthIs` idArity f
 147
 148                    other -> add_par (hang (ppr f) 2 pp_args)
 149
 150         other -> add_par (hang (pprParendExpr fun) 2 pp_args)
 151     }
 152
 153 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
 154   = add_par $
 155     sep [sep [ptext SLIT("case") <+> pprCoreExpr expr,
 156               ifPprDebug (braces (ppr ty)),
 157               sep [ptext SLIT("of") <+> ppr_bndr var,
 158                    char '{' <+> ppr_case_pat con args]
 159           ],
 160          pprCoreExpr rhs,
 161          char '}'
 162     ]
 163   where
 164     ppr_bndr = pprBndr CaseBind
 165
 166 ppr_expr add_par (Case expr var ty alts)
 167   = add_par $
 168     sep [sep [ptext SLIT("case")
 169                 <+> pprCoreExpr expr
 170                 <+> ifPprDebug (braces (ppr ty)),
 171               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 172          nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
 173          char '}'
 174     ]
 175   where
 176     ppr_bndr = pprBndr CaseBind
 177
 178
 179 -- special cases: let ... in let ...
 180 -- ("disgusting" SLPJ)
 181
 182 {-
 183 ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 184   = add_par $
 185     vcat [
 186       hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
 187       nest 2 (pprCoreExpr rhs),
 188       ptext SLIT("} in"),
 189       pprCoreExpr body ]
 190 -}
 191
 192 ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 193   = add_par
 194     (hang (ptext SLIT("let {"))
 195           2 (hsep [ppr_binding (val_bdr,rhs),
 196                    ptext SLIT("} in")])
 197      $$
 198      pprCoreExpr expr)
 199
 200 -- general case (recursive case, too)
 201 ppr_expr add_par (Let bind expr)
 202   = add_par $
 203     sep [hang (ptext keyword) 2 (ppr_bind bind),
 204          hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
 205   where
 206     keyword = case bind of
 207                 Rec _      -> SLIT("__letrec {")
 208                 NonRec _ _ -> SLIT("let {")
 209
 210 ppr_expr add_par (Note (SCC cc) expr)
 211   = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
 212
 213 ppr_expr add_par (Note InlineMe expr)
 214   = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
 215
 216 ppr_expr add_par (Note (TickBox mod n) expr)
 217   = add_par $
 218     sep [sep [ptext SLIT("__tick_box"),
 219                pprModule mod,
 220               text (show n)],
 221          pprParendExpr expr]
 222
 223 ppr_expr add_par (Note (BinaryTickBox mod t e) expr)
 224   = add_par $
 225     sep [sep [ptext SLIT("__binary_tick_box"),
 226                pprModule mod,
 227               text (show t),
 228               text (show e)],
 229          pprParendExpr expr]
 230
 231 ppr_expr add_par (Note (CoreNote s) expr)
 232   = add_par $
 233     sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
 234          pprParendExpr expr]
 235
 236 pprCoreAlt (con, args, rhs)
 237   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 238
 239 ppr_case_pat con@(DataAlt dc) args
 240   | isTupleTyCon tc
 241   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 242   where
 243     ppr_bndr = pprBndr CaseBind
 244     tc = dataConTyCon dc
 245
 246 ppr_case_pat con args
 247   = ppr con <+> sep (map ppr_bndr args) <+> arrow
 248   where
 249     ppr_bndr = pprBndr CaseBind
 250
 251 pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
 252 pprArg expr      = pprParendExpr expr
 253 \end{code}
 254
 255 Other printing bits-and-bobs used with the general @pprCoreBinding@
 256 and @pprCoreExpr@ functions.
 257
 258 \begin{code}
 259 instance OutputableBndr Var where
 260   pprBndr = pprCoreBinder
 261
 262 pprCoreBinder :: BindingSite -> Var -> SDoc
 263 pprCoreBinder LetBind binder
 264   = vcat [sig, pprIdDetails binder, pragmas]
 265   where
 266     sig     = pprTypedBinder binder
 267     pragmas = ppIdInfo binder (idInfo binder)
 268
 269 -- Lambda bound type variables are preceded by "@"
 270 pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
 271
 272 -- Case bound things don't get a signature or a herald, unless we have debug on
 273 pprCoreBinder CaseBind bndr
 274   = getPprStyle $ \ sty ->
 275     if debugStyle sty then
 276         parens (pprTypedBinder bndr)
 277     else
 278         pprUntypedBinder bndr
 279
 280 pprUntypedBinder binder
 281   | isTyVar binder = ptext SLIT("@") <+> ppr binder     -- NB: don't print kind
 282   | otherwise      = pprIdBndr binder
 283
 284 pprTypedBinder binder
 285   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
 286   | otherwise       = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
 287
 288 pprTyVarBndr :: TyVar -> SDoc
 289 pprTyVarBndr tyvar
 290   = getPprStyle $ \ sty ->
 291     if debugStyle sty then
 292         hsep [ppr tyvar, dcolon, pprParendKind kind]
 293                 -- See comments with ppDcolon in PprCore.lhs
 294     else
 295         ppr tyvar
 296   where
 297     kind = tyVarKind tyvar
 298
 299 -- pprIdBndr does *not* print the type
 300 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 301 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 302
 303 pprIdBndrInfo info
 304   = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
 305   where
 306     prag_info = inlinePragInfo info
 307     occ_info  = occInfo info
 308     dmd_info  = newDemandInfo info
 309     lbv_info  = lbvarInfo info
 310
 311     no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
 312               (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
 313               hasNoLBVarInfo lbv_info
 314
 315     doc | no_info = empty
 316         | otherwise
 317         = brackets $ hsep [ppr prag_info, ppr occ_info,
 318                            ppr dmd_info, ppr lbv_info
 319 #ifdef OLD_STRICTNESS
 320                            , ppr (demandInfo id)
 321 #endif
 322                           ]
 323 \end{code}
 324
 325
 326 \begin{code}
 327 pprIdDetails :: Id -> SDoc
 328 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
 329                 | isExportedId id   = ptext SLIT("[Exported]")
 330                 | otherwise         = empty
 331
 332 ppIdInfo :: Id -> IdInfo -> SDoc
 333 ppIdInfo b info
 334   = brackets $
 335     vcat [  ppArityInfo a,
 336             ppWorkerInfo (workerInfo info),
 337             ppCafInfo (cafInfo info),
 338 #ifdef OLD_STRICTNESS
 339             ppStrictnessInfo s,
 340             ppCprInfo m,
 341 #endif
 342             pprNewStrictness (newStrictnessInfo info),
 343             if null rules then empty
 344             else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
 345         -- Inline pragma, occ, demand, lbvar info
 346         -- printed out with all binders (when debug is on);
 347         -- see PprCore.pprIdBndr
 348         ]
 349   where
 350     a = arityInfo info
 351 #ifdef OLD_STRICTNESS
 352     s = strictnessInfo info
 353     m = cprInfo info
 354 #endif
 355     rules = specInfoRules (specInfo info)
 356 \end{code}
 357
 358
 359 \begin{code}
 360 instance Outputable CoreRule where
 361    ppr = pprRule
 362
 363 pprRules :: [CoreRule] -> SDoc
 364 pprRules rules = vcat (map pprRule rules)
 365
 366 pprRule :: CoreRule -> SDoc
 367 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 368   = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 369
 370 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 371                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 372                 ru_rhs = rhs })
 373   = hang (doubleQuotes (ftext name) <+> ppr act)
 374        4 (sep [ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 375                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 376                nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
 377             ])
 378 \end{code}