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