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