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