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 pprCoreExpr 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 (CoreNote s) expr)
 217   = add_par $
 218     sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
 219          pprParendExpr expr]
 220
 221 pprCoreAlt (con, args, rhs)
 222   = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
 223
 224 ppr_case_pat con@(DataAlt dc) args
 225   | isTupleTyCon tc
 226   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 227   where
 228     ppr_bndr = pprBndr CaseBind
 229     tc = dataConTyCon dc
 230
 231 ppr_case_pat con args
 232   = ppr con <+> sep (map ppr_bndr args) <+> arrow
 233   where
 234     ppr_bndr = pprBndr CaseBind
 235
 236 pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
 237 pprArg expr      = pprParendExpr expr
 238 \end{code}
 239
 240 Other printing bits-and-bobs used with the general @pprCoreBinding@
 241 and @pprCoreExpr@ functions.
 242
 243 \begin{code}
 244 instance OutputableBndr Var where
 245   pprBndr = pprCoreBinder
 246
 247 pprCoreBinder :: BindingSite -> Var -> SDoc
 248 pprCoreBinder LetBind binder
 249   = vcat [sig, pprIdDetails binder, pragmas]
 250   where
 251     sig     = pprTypedBinder binder
 252     pragmas = ppIdInfo binder (idInfo binder)
 253
 254 -- Lambda bound type variables are preceded by "@"
 255 pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
 256
 257 -- Case bound things don't get a signature or a herald, unless we have debug on
 258 pprCoreBinder CaseBind bndr
 259   = getPprStyle $ \ sty ->
 260     if debugStyle sty then
 261         parens (pprTypedBinder bndr)
 262     else
 263         pprUntypedBinder bndr
 264
 265 pprUntypedBinder binder
 266   | isTyVar binder = ptext SLIT("@") <+> ppr binder     -- NB: don't print kind
 267   | otherwise      = pprIdBndr binder
 268
 269 pprTypedBinder binder
 270   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
 271   | otherwise       = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
 272
 273 pprTyVarBndr :: TyVar -> SDoc
 274 pprTyVarBndr tyvar
 275   = getPprStyle $ \ sty ->
 276     if debugStyle sty then
 277         hsep [ppr tyvar, dcolon, pprParendKind kind]
 278                 -- See comments with ppDcolon in PprCore.lhs
 279     else
 280         ppr tyvar
 281   where
 282     kind = tyVarKind tyvar
 283
 284 -- pprIdBndr does *not* print the type
 285 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 286 pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 287
 288 pprIdBndrInfo info
 289   = megaSeqIdInfo `seq` doc -- The seq is useful for poking on black holes
 290   where
 291     prag_info = inlinePragInfo info
 292     occ_info  = occInfo info
 293     dmd_info  = newDemandInfo info
 294     lbv_info  = lbvarInfo info
 295
 296     no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
 297               (case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
 298               hasNoLBVarInfo lbv_info
 299
 300     doc | no_info = empty
 301         | otherwise
 302         = brackets $ hsep [ppr prag_info, ppr occ_info,
 303                            ppr dmd_info, ppr lbv_info
 304 #ifdef OLD_STRICTNESS
 305                            , ppr (demandInfo id)
 306 #endif
 307                           ]
 308 \end{code}
 309
 310
 311 \begin{code}
 312 pprIdDetails :: Id -> SDoc
 313 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
 314                 | isExportedId id   = ptext SLIT("[Exported]")
 315                 | otherwise         = empty
 316
 317 ppIdInfo :: Id -> IdInfo -> SDoc
 318 ppIdInfo b info
 319   = brackets $
 320     vcat [  ppArityInfo a,
 321             ppWorkerInfo (workerInfo info),
 322             ppCafInfo (cafInfo info),
 323 #ifdef OLD_STRICTNESS
 324             ppStrictnessInfo s,
 325             ppCprInfo m,
 326 #endif
 327             pprNewStrictness (newStrictnessInfo info),
 328             if null rules then empty
 329             else ptext SLIT("RULES:") <+> vcat (map pprRule rules)
 330         -- Inline pragma, occ, demand, lbvar info
 331         -- printed out with all binders (when debug is on);
 332         -- see PprCore.pprIdBndr
 333         ]
 334   where
 335     a = arityInfo info
 336 #ifdef OLD_STRICTNESS
 337     s = strictnessInfo info
 338     m = cprInfo info
 339 #endif
 340     rules = specInfoRules (specInfo info)
 341 \end{code}
 342
 343
 344 \begin{code}
 345 instance Outputable CoreRule where
 346    ppr = pprRule
 347
 348 pprRules :: [CoreRule] -> SDoc
 349 pprRules rules = vcat (map pprRule rules)
 350
 351 pprRule :: CoreRule -> SDoc
 352 pprRule (BuiltinRule { ru_fn = fn, ru_name = name})
 353   = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name)
 354
 355 pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
 356                 ru_bndrs = tpl_vars, ru_args = tpl_args,
 357                 ru_rhs = rhs })
 358   = hang (doubleQuotes (ftext name) <+> ppr act)
 359        4 (sep [ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 360                nest 2 (ppr fn <+> sep (map pprArg tpl_args)),
 361                nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
 362             ])
 363 \end{code}