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