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, pprCoreAlt,
  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                           globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
  25                         )
  26 import Var              ( isTyVar )
  27 import IdInfo           ( IdInfo, megaSeqIdInfo,
  28                           arityInfo, ppArityInfo,
  29                           specInfo, cprInfo, ppCprInfo,
  30                           strictnessInfo, ppStrictnessInfo,
  31                           cprInfo, ppCprInfo,
  32                           workerInfo, ppWorkerInfo,
  33                           tyGenInfo, ppTyGenInfo,
  34                           newDemandInfo, newStrictnessInfo
  35                         )
  36 import DataCon          ( dataConTyCon )
  37 import TyCon            ( tupleTyConBoxity, isTupleTyCon )
  38 import PprType          ( pprParendType, pprTyVarBndr )
  39 import BasicTypes       ( tupleParens )
  40 import PprEnv
  41 import Util             ( lengthIs )
  42 import Outputable
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{Public interfaces for Core printing (excluding instances)}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  52 function for ``major'' val_bdrs (those next to equal signs :-),
  53 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  54 usually be called through some intermediary.
  55
  56 The binder/occ printers take the default ``homogenized'' (see
  57 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  58 homogenized one, or they can ignore it completely.  In other words,
  59 the things passed in act as ``hooks'', getting the last word on how to
  60 print something.
  61
  62 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  63
  64 Un-annotated core dumps
  65 ~~~~~~~~~~~~~~~~~~~~~~~
  66 \begin{code}
  67 pprCoreBindings :: [CoreBind] -> SDoc
  68 pprCoreBinding  :: CoreBind   -> SDoc
  69 pprCoreExpr     :: CoreExpr   -> SDoc
  70 pprParendExpr   :: CoreExpr   -> SDoc
  71
  72 pprCoreBindings = pprTopBinds pprCoreEnv
  73 pprCoreBinding  = pprTopBind pprCoreEnv
  74 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
  75 pprParendExpr   = ppr_parend_expr   pprCoreEnv
  76 pprArg          = ppr_arg pprCoreEnv
  77 pprCoreAlt      = ppr_alt pprCoreEnv
  78
  79 pprCoreEnv = initCoreEnv pprCoreBinder
  80 \end{code}
  81
  82 Printer for unfoldings in interfaces
  83 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  84 \begin{code}
  85 instance Outputable b => Outputable (Bind b) where
  86     ppr bind = ppr_bind pprGenericEnv bind
  87
  88 instance Outputable b => Outputable (Expr b) where
  89     ppr expr = ppr_noparend_expr pprGenericEnv expr
  90
  91 pprGenericEnv :: Outputable b => PprEnv b
  92 pprGenericEnv = initCoreEnv (\site -> ppr)
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection{Instance declarations for Core printing}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101
 102 \begin{code}
 103 initCoreEnv pbdr
 104   = initPprEnv
 105         (Just pprCostCentreCore)        -- Cost centres
 106
 107         (Just ppr)              -- tyvar occs
 108         (Just pprParendType)    -- types
 109
 110         (Just pbdr) (Just ppr) -- value vars
 111         -- Use pprIdBndr for this last one as a debugging device.
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{The guts}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
 122
 123 pprTopBind pe (NonRec binder expr)
 124  = ppr_binding_pe pe (binder,expr) $$ text ""
 125
 126 pprTopBind pe (Rec binds)
 127   = vcat [ptext SLIT("Rec {"),
 128           vcat (map (ppr_binding_pe pe) binds),
 129           ptext SLIT("end Rec }"),
 130           text ""]
 131 \end{code}
 132
 133 \begin{code}
 134 ppr_bind :: PprEnv b -> Bind b -> SDoc
 135
 136 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 137 ppr_bind pe (Rec binds)           = vcat (map pp binds)
 138                                   where
 139                                     pp bind = ppr_binding_pe pe bind <> semi
 140
 141 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 142 ppr_binding_pe pe (val_bdr, expr)
 143   = sep [pBndr pe LetBind val_bdr,
 144          nest 2 (equals <+> ppr_noparend_expr pe expr)]
 145 \end{code}
 146
 147 \begin{code}
 148 ppr_parend_expr   pe expr = ppr_expr parens pe expr
 149 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
 150
 151 noParens :: SDoc -> SDoc
 152 noParens pp = pp
 153 \end{code}
 154
 155 \begin{code}
 156 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
 157         -- The function adds parens in context that need
 158         -- an atomic value (e.g. function args)
 159
 160 ppr_expr add_par pe (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)        -- Wierd
 161
 162 ppr_expr add_par pe (Var name) = pOcc pe name
 163 ppr_expr add_par pe (Lit lit)  = ppr lit
 164
 165 ppr_expr add_par pe expr@(Lam _ _)
 166   = let
 167         (bndrs, body) = collectBinders expr
 168     in
 169     add_par $
 170     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 171          2 (ppr_noparend_expr pe body)
 172
 173 ppr_expr add_par pe expr@(App fun arg)
 174   = case collectArgs expr of { (fun, args) ->
 175     let
 176         pp_args     = sep (map (ppr_arg pe) args)
 177         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 178         pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
 179     in
 180     case fun of
 181         Var f -> case isDataConId_maybe f of
 182                         -- Notice that we print the *worker*
 183                         -- for tuples in paren'd format.
 184                    Just dc | saturated && isTupleTyCon tc
 185                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 186                            where
 187                              tc        = dataConTyCon dc
 188                              saturated = val_args `lengthIs` idArity f
 189
 190                    other -> add_par (hang (pOcc pe f) 2 pp_args)
 191
 192         other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
 193     }
 194
 195 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
 196   = add_par $
 197     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
 198               hsep [ptext SLIT("of"),
 199                     ppr_bndr var,
 200                     char '{',
 201                     ppr_case_pat pe con args
 202           ]],
 203          ppr_noparend_expr pe rhs,
 204          char '}'
 205     ]
 206   where
 207     ppr_bndr = pBndr pe CaseBind
 208
 209 ppr_expr add_par pe (Case expr var alts)
 210   = add_par $
 211     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
 212               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 213          nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
 214          char '}'
 215     ]
 216   where
 217     ppr_bndr = pBndr pe CaseBind
 218
 219
 220 -- special cases: let ... in let ...
 221 -- ("disgusting" SLPJ)
 222
 223 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 224   = add_par $
 225     vcat [
 226       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 227       nest 2 (ppr_noparend_expr pe rhs),
 228       ptext SLIT("} in"),
 229       ppr_noparend_expr pe body ]
 230
 231 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 232   = add_par
 233     (hang (ptext SLIT("let {"))
 234           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 235                            2 (ppr_noparend_expr pe rhs),
 236        ptext SLIT("} in")])
 237      $$
 238      ppr_noparend_expr pe expr)
 239
 240 -- general case (recursive case, too)
 241 ppr_expr add_par pe (Let bind expr)
 242   = add_par $
 243     sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 244          hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
 245   where
 246     keyword = case bind of
 247                 Rec _      -> SLIT("__letrec {")
 248                 NonRec _ _ -> SLIT("let {")
 249
 250 ppr_expr add_par pe (Note (SCC cc) expr)
 251   = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
 252
 253 #ifdef DEBUG
 254 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 255  = add_par $
 256    getPprStyle $ \ sty ->
 257    if debugStyle sty && not (ifaceStyle sty) then
 258       sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
 259            ppr_parend_expr pe expr]
 260    else
 261       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 262                   ppr_parend_expr pe expr]
 263 #else
 264 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 265   = add_par $
 266     sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
 267          ppr_parend_expr pe expr]
 268 #endif
 269
 270 ppr_expr add_par pe (Note InlineCall expr)
 271   = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
 272
 273 ppr_expr add_par pe (Note InlineMe expr)
 274   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 275
 276 ppr_alt pe (con, args, rhs)
 277   = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
 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, pprIdDetails binder, 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("@") <+> ppr binder     -- NB: don't print kind
 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 -- pprIdBndr does *not* print the type
 328 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 329 pprIdBndr id = ppr id <+>
 330                (megaSeqIdInfo (idInfo id) `seq`
 331                         -- Useful for poking on black holes
 332                 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
 333                             ppr (idDemandInfo id)) <+> ppr (newDemandInfo (idInfo id)) <+>
 334                             ppr (idLBVarInfo id))
 335 \end{code}
 336
 337
 338 \begin{code}
 339 pprIdDetails :: Id -> SDoc
 340 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
 341                 | isExportedId id   = ptext SLIT("[Exported]")
 342                 | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
 343                 | otherwise         = empty
 344
 345 ppIdInfo :: Id -> IdInfo -> SDoc
 346 ppIdInfo b info
 347   = hsep [  ppArityInfo a,
 348             ppTyGenInfo g,
 349             ppWorkerInfo (workerInfo info),
 350             ppStrictnessInfo s,
 351             ppCprInfo m,
 352             ppr (newStrictnessInfo info),
 353             pprCoreRules b p
 354         -- Inline pragma, occ, demand, lbvar info
 355         -- printed out with all binders (when debug is on);
 356         -- see PprCore.pprIdBndr
 357         ]
 358   where
 359     a = arityInfo info
 360     g = tyGenInfo info
 361     s = strictnessInfo info
 362     m = cprInfo info
 363     p = specInfo info
 364 \end{code}
 365
 366
 367 \begin{code}
 368 pprCoreRules :: Id -> CoreRules -> SDoc
 369 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
 370
 371 pprIdCoreRule :: IdCoreRule -> SDoc
 372 pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
 373
 374 pprCoreRule :: SDoc -> CoreRule -> SDoc
 375 pprCoreRule pp_fn (BuiltinRule name _)
 376   = ifPprDebug (ptext SLIT("Built in rule") <+> doubleQuotes (ptext name))
 377
 378 pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
 379   = doubleQuotes (ptext name) <+> ppr act <+>
 380     sep [
 381           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 382           nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
 383           nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
 384     ] <+> semi
 385 \end{code}